*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
      REAL
     +   ABSTOL
      INTEGER
     +   N,NFAIL
C
C  ARRAY ARGUMENTS
      REAL
     +   V(*),W(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL V(N), W(N)
C        THE VALUES BEING COMPARED.
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
*ACCDIG
      SUBROUTINE ACCDIG(AX, X, AD, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     RETURNS NUMBER OF ACCURATE DIGITS, AD, IN AX AN APPROXIMATION TO X
C
C     WRITTEN BY DAVID HOGBEN, SEL, NBS.   10/29/69.
C
C     THIS ROUTINE WAS ADAPTED FROM THE OMNITAB ROUTINE ACCDIG
C     BY - -
C
C     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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   AD(*),AX(*),X(*)
C
C  LOCAL SCALARS
      REAL
     +   ADMAX,DIFF,FPLRS
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG10,MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AD(N)
C        THE NUMBER OF ACCURATE DIGITS.
C     REAL ADMAX
C        THE NUMBER OF DIGITS CARRIED IN A FLOATING POINT COMPUTATION.
C     REAL AX(N)
C        THE APPROXIMATION TO THE SOLUTION.
C     REAL DIFF
C        *
C     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     INTEGER I
C        AN INDEX.
C     INTEGER N
C        THE NUMBER OF ELEMENTS BEING COMPARED.
C     REAL X(N)
C        THE SOLUTION.
C
C
      FPLRS = R1MACH(4)
C
      ADMAX = -LOG10(FPLRS)
C
      DO 20 I=1,N
         DIFF = AX(I) - X(I)
         IF (DIFF.NE.0.0E0) GO TO 10
         AD(I) = ADMAX
         GO TO 20
   10    AD(I) = 0.0E0
         IF (ABS(X(I)).GT.0.0E0) AD(I) = LOG10(ABS(X(I)))
         IF (ABS(DIFF).GT.0.0E0) AD(I) = -LOG10(ABS(DIFF)) + AD(I)
         AD(I) = MIN(ADMAX,AD(I))
         AD(I) = MAX(-ADMAX,AD(I))
   20 CONTINUE
      RETURN
      END
*ACFD
      SUBROUTINE ACFD (Y, N, LAGMAX, NFAC, ND, IOD, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO-
C     CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES
C     WITH DIFFERENCING.
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
     +   LAGMAX,LDSTAK,N,NFAC
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
      INTEGER
     +   IOD(*),ND(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YSD
      INTEGER
     +   ACOV,AIC,FTEST,I,IAR,IFP,IPRT,LACOV,LDSMIN,LYFFT,NALL0,
     +   NFFT,NTIMES,NYD,NYF,PHI,PRHO,SDRHO,WORK,YF
      LOGICAL
     +   DIFFER,ISFFT,NEWPG
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFER,ACFMN,ACFOUT,DIFSER,IPRINT,LDSCMP,SCOPY,STKCLR,
     +   STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ACOV
C        THE STARTING LOCATION IN DSTAK FOR
C        THE AUTOCOVARIANCE VECTOR.
C     INTEGER AIC
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE VARIABLE USED TO DESIGNATE WHETHER OR NOT THE SERIES
C        BEING ANALYZED WAS DIFFERENCED OR NOT.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER FTEST
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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     INTEGER IFP
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING
C        POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION.
C     INTEGER IOD(NFAC)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        A DUMMY VARIABLE
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER ND(NFAC)
C        THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE
C        FACTORS ARE TO BE APPLIED.
C     INTEGER NDUM(1)
C        A DUMMY DIMENSIONED VARIABLE.
C     LOGICAL NEWPG
C        THE VARIABLE USED TO DESIGNATE WHETHER OR NOT THE OUTPUT
C        IS TO BEGIN ON A NEW PAGE.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NTIMES
C        THE NUMBER OF TIMES THE FIRST DIFFERENCE FACTOR HAS BEEN
C        APPLIED.
C     INTEGER NYD, NYF
C        THE NUMBER OF OBSERVATIONS AFTER THE DIFFERENCE FILTER IS
C        APPLIED.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR).
C     INTEGER PHI
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     INTEGER PRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR PRHO.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR SDRHO.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR WORK.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     INTEGER YF
C        THE STARTING LOCATION IN DSTAK FOR
C        THE VECTOR CONTAINING THE DIFFERENCE FILTERED SERIES.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'A',       'C',       'F',       'D',       ' ',       ' '/
C
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      LACOV = LAGMAX+1
      DIFFER = .TRUE.
      ISFFT = .FALSE.
      LYFFT = 0
      NFFT = 0
C
      CALL LDSCMP(7, 0, 0, 0, 0, 0, 'S', 7*LAGMAX+2+N, LDSMIN)
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET(LDSTAK, 4)
        NALL0 = STKST(1)
C
        IFP = 3
C
        ACOV = STKGET(LAGMAX+1, IFP)
        PRHO = STKGET(LAGMAX, IFP)
        AIC = STKGET(LAGMAX+1, IFP)
        FTEST = STKGET(2*LAGMAX, IFP)
        PHI = STKGET(LAGMAX, IFP)
        WORK = STKGET(LAGMAX, IFP)
        YF = STKGET(N, IFP)
        SDRHO = WORK
C
        IF (IERR.EQ.0) THEN
C
          NEWPG = .FALSE.
          NTIMES = 0
C
C         CHECK WHETHER THERE IS MORE THAN ONE DIFFERENCE FACTOR.
C
          IF (NFAC.LE.1) THEN
            CALL SCOPY(N, Y, 1, RSTAK(YF), 1)
          ELSE
C
C           CREATE NEW DATA BY APPLYING DIFFERENCE FACTORS BEYOND THE
C           FIRST.
C
            CALL DIFSER(Y, N, NFAC-1, ND(2), IOD(2), RSTAK(YF), NYF)
          END IF
          NYD = N
C
C         CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
          CALL ACFMN (RSTAK(YF), NYD, MIN(LAGMAX, NYD-1),
     +       RSTAK(ACOV+1), RSTAK(SDRHO), YMEAN, RSTAK(PRHO),
     +       RSTAK(AIC), RSTAK(FTEST), RSTAK(PHI), IAR, OSPVAR,
     +       RSTAK(ACOV), LAGMAX+1, LAGMAX+1, CHIA, CHIAP, RSTAK(WORK),
     +       1)
C
          YSD = SQRT(RSTAK(ACOV) * N / (N-1))
C
C         CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
          CALL ACFOUT (YMEAN, YSD, NYF, NYF, MIN(LAGMAX, NYD-1),
     +       RSTAK(ACOV+1), RSTAK(SDRHO), RSTAK(PRHO), NDUM, RSTAK(AIC),
     +       LAGMAX+1, RSTAK(FTEST), IAR, RSTAK(PHI), OSPVAR, CHIA,
     +       CHIAP, LAGMAX, .FALSE., 0.0E0, DIFFER, NEWPG, NFAC, ND,
     +       IOD, NTIMES)
C
          NEWPG = .TRUE.
C
C         COMPUTE CORRELATION ANALYSIS FOR FIRST DIFFERENCE FACTOR
C         APPLIED 1 TO ND(1) TIMES
C
          IF ((NFAC.GE.1) .AND. (ND(1).GE.1)) THEN
            DO 50 I = 1, ND(1)
C
               CALL DIFSER(RSTAK(YF), NYD, NFAC-1, ND(2), IOD(2),
     +           RSTAK(YF), NYF)
C
C              CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
             CALL ACFMN (RSTAK(YF), NYD, MIN(LAGMAX, NYD-1),
     +          RSTAK(ACOV+1), RSTAK(SDRHO), YMEAN, RSTAK(PRHO),
     +          RSTAK(AIC), RSTAK(FTEST), RSTAK(PHI), IAR, OSPVAR,
     +          RSTAK(ACOV), LAGMAX+1, LAGMAX+1, CHIA, CHIAP,
     +          RSTAK(WORK), 1)
C
               YSD = SQRT(RSTAK(ACOV) * N / (N-1))
C
C           CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
             CALL ACFOUT (YMEAN, YSD, NYF, NYF, MIN(LAGMAX, NYD-1),
     +          RSTAK(ACOV+1), RSTAK(SDRHO), RSTAK(PRHO), NDUM,
     +          RSTAK(AIC), LAGMAX+1, RSTAK(FTEST), IAR, RSTAK(PHI),
     +          OSPVAR, CHIA, CHIAP, LAGMAX, .FALSE., 0.0E0, DIFFER,
     +          NEWPG, NFAC, ND, IOD, I)
C
   50       CONTINUE
          END IF
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL ACFD (Y, N, LAGMAX, NFAC, ND, IOD, LDSTAK)')
      END
*ACFDTL
      SUBROUTINE ACFDTL (NDF, ND, IOD, NTIMES)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS TITLING FOR ACORRD.
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
     +   NDF,NTIMES
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IOD(*),ND(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,ISTOP
      CHARACTER
     +   ICOM*1,IPER*1,IPUNCT*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     CHARACTER*1 ICOM
C        THE HOLLERITH VALUE -,- (COMMA)
C     INTEGER IOD(NDF)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     CHARACTER*1 IPER
C        THE HOLLERITH VALUE -.- (PERIOD)
C     INTEGER IPRT
C        THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED
C        OUTPUT.
C     CHARACTER*1 IPUNCT
C        THE HOLLERITH VALUE OF EITHER COMMA OR PERIOD.
C     INTEGER ISTOP
C        ONE LESS THAN THE NUMBER OF DIFFERENCE FACTORS.
C     INTEGER ND(NDF)
C        THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE
C        FACTORS ARE TO BE APPLIED.
C     INTEGER NDF
C        THE NUMBER OF DIFFERENCE FACTORS.
C     INTEGER NTIMES
C        THE NUMBER OF TIMES THE DIFFERENCING FACTOR HAS BEEN APPLIED.
C
      DATA ICOM/','/, IPER/'.'/
C
      CALL IPRINT (IPRT)
C
      IF (NDF .LE. 1) GO TO 10
C
      ISTOP = NDF - 1
      IPUNCT = IPER
      IF (NTIMES .GE. 1) IPUNCT = ICOM
      WRITE(IPRT, 1000)
      IF (NDF .EQ. 2)  WRITE(IPRT, 1001) ND(2), IOD(2), IPER
      IF (NDF .GE. 3) WRITE(IPRT, 1001)
     +   (ND(I), IOD(I), ICOM, I = 1, ISTOP), ND(NDF), IOD(NDF), IPUNCT
      GO TO 20
C
   10 WRITE(IPRT, 1002)
C
   20 IF (NTIMES .EQ. 0) RETURN
C
      IF (NDF .GE. 2) WRITE(IPRT, 1003) NTIMES, IOD(1)
      IF (NDF .EQ. 1) WRITE(IPRT, 1004) NTIMES, IOD(1)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(//47H SERIES ANALYZED IS INPUT SERIES DIFFERENCED BY/)
 1001 FORMAT(3X, 3(I3, ' FACTOR(S) OF ORDER ', I3, A1, 1X)/)
 1002 FORMAT(//' SERIES ANALYZED IS ORIGINAL INPUT SERIES'/)
 1003 FORMAT(4X, 34H AND, IN ADDITION, DIFFERENCED BY , I3,
     +   18H FACTORS OF ORDER , I3, '.'//)
 1004 FORMAT(4X, 16H DIFFERENCED BY , I3, 18H FACTORS OF ORDER ,
     +   I3, '.'//)
      END
*ACFER
      SUBROUTINE ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR THE ACF FAMILY
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
     +   LACOV,LAGMAX,LDSMIN,LDSTAK,LYFFT,N,NFAC,NFFT
      LOGICAL
     +   DIFFER,ISFFT
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IOD(*),ND(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERR(15)
      CHARACTER
     +   LLACOV(8)*1,LLAGMX(8)*1,LLDS(8)*1,LLGMX1(8)*1,
     +   LLYFFT(8)*1,LN(8)*1,LNFFT(8)*1,LNM1(8)*1,LONE(8)*1,
     +   LTHREE(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,ERDF
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL DIFFER
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE)
C     LOGICAL ERR(15)
C        VALUES 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 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     INTEGER IOD(NFAC)
C        THE ORDER OF EACH OF THE DIFFERENCE VACTORS
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
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 LLACOV(8), LLAGMX(8), LLDS(8), LLGMX1(8), LLYFFT(8),
C    *  LN(8), LNFFT(8), LNM1(8), LONE(8), LTHREE(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER ND(NFAC)
C        THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE FACTORS
C        ARE TO BE APPLIED
C     INTEGER NFAC
C        THE NUMBER OF FACTORS.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     + LLACOV(1), LLACOV(2), LLACOV(3), LLACOV(4), LLACOV(5),
     + LLACOV(6), LLACOV(7), LLACOV(8) /'L','A','C','O','V',' ',' ',' '/
      DATA
     + LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5),
     + LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ',' '/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5),
     + LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+','1'/
      DATA
     + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     + LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ',' '/
      DATA
     + LN(1), LN(2), LN(3), LN(4), LN(5),
     + LN(6), LN(7), LN(8) /'N',' ',' ',' ',' ',' ',' ',' '/
      DATA
     + LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5),
     + LNM1(6), LNM1(7), LNM1(8) /'(','N','-','1',')',' ',' ',' '/
      DATA
     + LNFFT(1), LNFFT(2), LNFFT(3), LNFFT(4), LNFFT(5),
     + LNFFT(6), LNFFT(7), LNFFT(8) /'N','F','F','T',' ',' ',' ',' '/
      DATA
     + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5),
     + LONE(6), LONE(7), LONE(8) /'O','N','E',' ',' ',' ',' ',' '/
      DATA
     + LTHREE(1), LTHREE(2), LTHREE(3), LTHREE(4), LTHREE(5),
     + LTHREE(6), LTHREE(7), LTHREE(8) /'T','H','R','E','E',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
      DO 10 I = 1, 15
        ERR(I) = .FALSE.
   10 CONTINUE
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, ERR(1), LTHREE)
C
      IF (.NOT.ERR(1)) THEN
C
        CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2), LONE,
     +    LNM1)
C
        IF (DIFFER) CALL ERDF(NMSUB, NFAC, ND, IOD, N, HEAD, ERR(3))
C
        IF (.NOT.ERR(2)) THEN
C
          CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 2, HEAD, ERR(4),
     +      LLGMX1)
C
          CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(5), LLDS)
C
          IF (ISFFT)
     +      CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 2, HEAD, ERR(6),
     +      LNFFT)
        END IF
      END IF
C
      DO 20 I = 1, 15
        IF (ERR(I)) IERR = 1
   20 CONTINUE
C
      RETURN
C
      END
*ACF
      SUBROUTINE ACF (Y, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO-
C     CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES
C     (SHORT CALL).
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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YSD
      INTEGER
     +   IAR,IPRT,LACOV,LAGMAX,LAIC,LDSMIN,LDSTAK,LYFFT,NFAC,NFFT,
     +   NPRT
      LOGICAL
     +   DIFFER,ISFFT
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),AIC(101),FTEST(2,100),PHI(100),PRHO(100),RHO(100),
     +   SDRHO(100),WORK(100)
      INTEGER
     +   IOD(1),ND(1),NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFER,ACFMN,ACFOUT,IPRINT,SETLAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (ACOV(2),RHO(1))
      EQUIVALENCE (WORK(1),SDRHO(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR.
C     REAL AIC(101)
C        THE ARRAY CONTAINING AKIAKES CRITERIA FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE)
C     REAL FTEST(2, 100)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 IOD(1)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER ND(1)
C        THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED
C     INTEGER NDUM(1)
C        A DUMMY ARRAY.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING THE PRINTED OUTPUT.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR).
C     REAL PHI(100)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     REAL PRHO(100)
C        THE ARRAY CONTAINING THE PARTIAL ACF ESTIMATES.
C     REAL RHO(100)
C        THE ARRAY CONTAINING THE ACF ESTIMATES.
C     REAL SDRHO(100)
C        THE ARRAY CONTAINING THE STANDARD ERRORS OF THE ACF ESTIMATES.
C     REAL WORK(100)
C        A VECTOR USED IN THE COMPUTATIONS OF THE PARTIAL
C        AUTOCORRELATION COEFFICIENTS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     REAL YMEAN, YSD
C        THE MEAN AND STANDARD DEVIATION OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5), NMSUB(6)
     + /     'A',       'C',       'F',       ' ',       ' ',      ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      LAGMAX = 1
      LACOV = 101
      LAIC = 101
      LDSMIN = 0
      LDSTAK = 0
      NPRT = 1
      DIFFER = .FALSE.
      NFAC = 1
      ND(1) = 0
      IOD(1) = 0
      ISFFT = .FALSE.
      LYFFT = N
      NFFT = N
C
      CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
      IF (IERR.EQ.0) THEN
C
C       SET NUMBER OF ACF TO BE COMPUTED
C
        CALL SETLAG (N, LAGMAX)
C
C       CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
        CALL ACFMN (Y, N, LAGMAX, RHO, SDRHO, YMEAN, PRHO, AIC, FTEST,
     +     PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA, CHIAP, WORK, NPRT)
C
        YSD = SQRT(ACOV(1) * N / (N-1))
C
C       CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
        CALL ACFOUT (YMEAN, YSD, N, N, LAGMAX, RHO, SDRHO, PRHO, NDUM,
     +     AIC, LAIC, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP, LAGMAX,
     +     .FALSE., 0.0E0, .FALSE., .FALSE., 0, NDUM, NDUM, 0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   22H       CALL ACF (Y, N))
      END
*ACFF
      SUBROUTINE ACFF (YFFT, N, LYFFT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO-
C     CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES
C     USING AN FFT (SHORT CALL).
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
     +   LDSTAK,LYFFT,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YSD
      INTEGER
     +   IAR,IFP,IPRT,LACOV,LAGMAX,LAIC,LDSMIN,NALL0,NFAC,NFFT,
     +   SDRHO,WORK
      LOGICAL
     +   DIFFER,ISFFT
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),AIC(101),FTEST(2,100),PHI(100),PRHO(100),RHO(100),
     +   RSTAK(12)
      INTEGER
     +   IOD(1),ND(1),NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFER,ACFMNF,ACFOUT,FFTLEN,IPRINT,LDSCMP,SETLAG,STKCLR,
     +   STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (ACOV(2),RHO(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE VECTOR.
C     REAL AIC(101)
C       THE ARRAY CONTAINING AKAIKES CRITERIA FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE)
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FTEST(2, 100)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 .NE. 0 ERRORS WERE DETECTED.
C     INTEGER IFP
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING
C        POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION.
C     INTEGER IOD(1)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER ND(1)
C        THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED
C     INTEGER NDUM(1)
C        A DUMMY ARRAY.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR).
C     REAL PHI(100)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     REAL PRHO(100)
C        THE ARRAY CONTAINING THE PARITAL ACF ESTIMATES.
C     REAL RHO(100)
C        THE ARRAY CONTAINING THE ACF ESTIMATES.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHO
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE STANDARD ERRORS OF THE ACF ESTIMATES.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR WORK.
C     REAL YFFT(LYFFT)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'A',       'C',       'F',       'F',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      LACOV = 101
      LAIC = 101
      DIFFER = .FALSE.
      NFAC = 1
      ND(1) = 0
      IOD(1) = 0
      ISFFT = .TRUE.
C
      IF (N.GE.3) THEN
C
C     SET NUMBER OF ACF TO BE COMPUTED
C     AND LENGTH OF EXTENDED SERIES
C
         CALL SETLAG(N, LAGMAX)
         CALL FFTLEN(N+LAGMAX, 4, NFFT)
      END IF
C
      CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN)
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET (LDSTAK, 4)
        NALL0 = STKST(1)
C
        IFP = 3
C
        WORK = STKGET(NFFT, IFP)
        SDRHO = WORK
C
        IF (IERR.EQ.0) THEN
C
C         CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
          CALL ACFMNF (YFFT, N, NFFT, LAGMAX, RHO, RSTAK(SDRHO), YMEAN,
     +       PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC,
     +       CHIA, CHIAP, LYFFT, RSTAK(WORK), NFFT, 1)
C
          YSD = SQRT (ACOV(1) * N / (N - 1))
C
C         CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
          CALL ACFOUT(YMEAN, YSD, N, N, LAGMAX, RHO, RSTAK(SDRHO), PRHO,
     +       NDUM, AIC, LAIC, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP,
     +       LAGMAX, .FALSE., 0.0E0, .FALSE., .FALSE., 0, NDUM, NDUM,
     +       0)
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL ACFF (YFFT, N, LYFFT, LDSTAK)')
      END
*ACFFS
      SUBROUTINE ACFFS (YFFT, N, LYFFT, LDSTAK, LAGMAX, LACOV, ACOV,
     +   IAR, PHI, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO-
C     CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES
C     USING A FFT WITH THE COMPUTED ACVF ESTIMATES RETURNED TO THE USERS
C     ROUTINE (LONG CALL).
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
     +   IAR,LACOV,LAGMAX,LDSTAK,LYFFT,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),PHI(*),YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YSD
      INTEGER
     +   AIC,FTEST,I,IFP,IPRT,LDSMIN,NALL0,NFAC,NFFT,PRHO,SDRHO,
     +   WORK
      LOGICAL
     +   DIFFER,ISFFT
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   IOD(1),ND(1),NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFER,ACFMNF,ACFOUT,FFTLEN,IPRINT,LDSCMP,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE VECTOR.
C     INTEGER AIC
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE)
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER FTEST
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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     INTEGER IFP
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING
C        POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION.
C     INTEGER IOD(1)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER ND(1)
C        THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED
C     INTEGER NDUM(1)
C        A DUMMY DIMENSIONED VARIABLE.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS MADE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR).
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     INTEGER PRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR PRHO.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR SDRHO.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR WORK.
C     REAL YFFT(LYFFT)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'A',       'C',       'F',       'F',       'S',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      DIFFER = .FALSE.
      NFAC = 1
      ND(1) = 0
      IOD(1) = 0
      ISFFT = .TRUE.
C
C     SET LENGTH OF EXTENDED SERIES
C
      NFFT = 0
      IF ((N.GE.3) .AND. (LAGMAX.GE.1)) CALL FFTLEN(N+LAGMAX, 4, NFFT)
C
      CALL LDSCMP(4, 0, 0, 0, 0, 0, 'S', (4*LAGMAX+1) + NFFT, LDSMIN)
C
      CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET(LDSTAK, 4)
        NALL0 = STKST(1)
C
        IFP = 3
C
        WORK = STKGET(NFFT, IFP)
        PRHO = STKGET(LAGMAX, IFP)
        AIC = STKGET(LAGMAX+1, IFP)
        FTEST = STKGET(2*LAGMAX, IFP)
        SDRHO = WORK
C
        IF (IERR.EQ.0) THEN
C
C         CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
          CALL ACFMNF (YFFT, N, NFFT, LAGMAX, ACOV(2), RSTAK(SDRHO),
     +       YMEAN, RSTAK(PRHO), RSTAK(AIC), RSTAK(FTEST), PHI,
     +       IAR, OSPVAR, ACOV, LACOV, LAGMAX+1, CHIA, CHIAP,
     +       LYFFT, RSTAK(WORK), NFFT, NPRT)
C
          YSD = SQRT (ACOV(1) * N / (N - 1))
C
C         CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
          IF ((NPRT.NE.0) .OR. (ACOV(1).EQ.0.0E0))
     +       CALL ACFOUT (YMEAN, YSD, N, N, LAGMAX, ACOV(2),
     +       RSTAK(SDRHO),
     +       RSTAK(PRHO), NDUM, RSTAK(AIC), LAGMAX+1, RSTAK(FTEST), IAR,
     +       PHI, OSPVAR, CHIA, CHIAP, LAGMAX, .FALSE., 0.0E0, .FALSE.,
     +       .FALSE., 0, NDUM, NDUM, 0)
C
          IF (NPRT.NE.0) THEN
            DO 50 I = 1, LAGMAX
               ACOV(I+1) = ACOV(I+1) * ACOV(1)
   50       CONTINUE
          END IF
C
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL ACFFS (YFFT, N, LYFFT, LDSTAK,'/
     +  '      +            LAGMAX, LACOV, ACOV, IAR, PHI, NPRT)')
      END
*ACFLST
      SUBROUTINE ACFLST (RHO, SDRHO, NLPPA, LAGMAX, IFMISS, CHIA,
     +   NDFCHI, CHIAP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE ACTUALLY LISTS THE AUTOCORRELATIONS OR
C     PARTIAL AUTOCORRELATIONS AND OTHER PERTINENT INFORMATION.
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
      REAL
     +   CHIA,CHIAP
      INTEGER
     +   LAGMAX,NDFCHI
      LOGICAL
     +   IFMISS
C
C  ARRAY ARGUMENTS
      REAL
     +   RHO(*),SDRHO(*)
      INTEGER
     +   NLPPA(*)
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,IMAX,IMIN,IPRT,LAG,NPERL
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CHIA, CHIAP
C        THE VARIABLES IN CHICH THE CHI SQUARE STATISTIC AND
C        PROBABILITY FOR THE AUTOCORRELATIONS ARE STORED.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     LOGICAL IFMISS
C        THE INDICATOR VARIABLE USED TO DETERMINE
C        WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT.
C     INTEGER IMAX, IMIN
C        THE INDEX VALUES OF THE FIRST AND LAST OBSERVATION
C        TO BE PRINTED PER LINE
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT
C     INTEGER LAG
C        THE LAG VALUE OF THE AUTOCORRELATION OR PARTIAL
C        AUTOCORRELATION BEING PRINTED.
C     INTEGER LAGMAX
C        THE NUMBER OF AUTOCORRELATIONS OR PARTIAL AUTOCORRELATIONS
C        TO BE PRINTED.
C     INTEGER NDFCHI
C        THE DEGREES OF FREEDOM FOR THE CHI SQUARED STATISTIC.
C     INTEGER NLPPA(LAGMAX)
C        THE ARRAY IN WHICH THE NUMBER OF LAGGED PRODUCT PAIRS USED TO
C        COMPUTE EACH AUTOCORRELATION IS STORED
C     INTEGER NPERL
C        THE NUMBER OF VALUES TO BE PRINTED PER LINE.
C     REAL RHO(LAGMAX)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED.
C     REAL SDRHO(LAGMAX)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C
C
      FPLM = R1MACH(2)
C
      CALL IPRINT(IPRT)
C
      NPERL = 12
      DO 30 I = 1, LAGMAX, NPERL
         IMIN = I
         IMAX = MIN(I + NPERL - 1, LAGMAX)
         WRITE(IPRT, 1000) (LAG, LAG = IMIN, IMAX)
         WRITE(IPRT, 1001) (RHO(LAG), LAG = IMIN, IMAX)
         WRITE(IPRT, 1002) (SDRHO(LAG), LAG = IMIN, IMAX)
         IF (IFMISS) WRITE(IPRT, 1003) (NLPPA(LAG), LAG = IMIN, IMAX)
   30 CONTINUE
C
      IF (SDRHO(LAGMAX) .EQ. FPLM) WRITE(IPRT, 1004) FPLM
C
      WRITE (IPRT, 1005) CHIA, NDFCHI, CHIAP
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/19H LAG               , 12(1X, I6))
 1001 FORMAT( 19H ACF               , 12(2X, F5.2))
 1002 FORMAT( 19H STANDARD ERROR    , 12(2X, F5.2))
 1003 FORMAT( 19H NO. OF OBS. USED  , 12(1X, I6))
 1004 FORMAT(///5X, F5.2, 38H INDICATES VALUE COULD NOT BE COMPUTED,
     +   ' DUE TO MISSING DATA.')
 1005 FORMAT(///33H THE CHI SQUARE TEST STATISTIC OF/
     +   40H THE NULL HYPOTHESIS OF WHITE NOISE    =, G21.4/
     +   40H DEGREES OF FREEDOM                    =, I17/
     +   40H OBSERVED SIGNIFICANCE LEVEL           =, F17.4)
      END
*ACFM
      SUBROUTINE ACFM (Y, YMISS, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO-
C     CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES
C     WITH MISSING VALUES (SHORT CALL).
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
      REAL
     +   YMISS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YSD
      INTEGER
     +   IAR,IPRT,LACOV,LAGLST,LAGMAX,LAIC,LDSMIN,LDSTAK,LYFFT,
     +   NFAC,NFFT,NPRT
      LOGICAL
     +   DIFFER,ISFFT
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),AIC(101),FTEST(2,100),PHI(100),PRHO(100),RHO(100),
     +   SDRHO(100),WORK(100)
      INTEGER
     +   IOD(1),ND(1),NDUM(1),NLPPA(101)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFER,ACFMNM,ACFOUT,IPRINT,SETLAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (ACOV(2),RHO(1))
      EQUIVALENCE (WORK(1),SDRHO(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE VECTOR.
C     REAL AIC(101)
C        THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE)
C     REAL FTEST(2, 100)
C        THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 IOD(1)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGLST
C        THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF THE
C        SERIES NOT TO BE COMPUTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        A DUMMY VARIABLE.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER ND(1)
C        THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED
C     INTEGER NDUM(1)
C        A DUMMY ARRAY.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS MADE.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NLPPA(101)
C        THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS
C        USED TO COMPUTE EACH ACVF ESTIMATE.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR).
C     REAL PHI(100)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     REAL PRHO(100)
C        THE ARRAY CONTAINING THE PACF ESTIMATES.
C     REAL RHO(100)
C        THE ARRAY CONTAINING THE ACF ESTIMATES.
C     REAL SDRHO(100)
C        THE ARRAY CONTAINING THE STANDARD ERRORS OF THE ACF.
C     REAL WORK(100)
C        THE ARRAY CONTAINING WORK AREA FOR THE PACF COMPUTATIONS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER
C        OR NOT AN OBSERVATION IN THE SERIES IS MISSING.
C        IF Y(I) .EQ. YMISS, THE VALUE IS ASSUMED MISSING.
C        IF Y(I) .NE. YMISS, THE VALUE IS ASSUMED NOT MISSING.
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'A',       'C',       'F',       'M',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      LAGMAX = 1
      LACOV = 101
      LAIC = 101
      NPRT = 1
      LDSMIN = 0
      LDSTAK = 0
      DIFFER = .FALSE.
      NFAC = 1
      ND(1) = 0
      IOD(1) = 0
      ISFFT = .FALSE.
      LYFFT = N
      NFFT = N
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET LARGEST LAG TO BE USED.
C
        CALL SETLAG(N, LAGMAX)
C
C       CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
        CALL ACFMNM (Y, YMISS, N, LAGMAX, RHO, SDRHO, NLPPA, YMEAN,
     +     PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA,
     +     CHIAP, LAGLST, WORK, NPRT)
C
        YSD = ACOV(1)
        IF (LAGLST.GE.0) YSD = SQRT (ACOV(1) * N / (N - 1))
C
C       CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
        CALL ACFOUT (YMEAN, YSD, N, NLPPA(1), LAGMAX, RHO, SDRHO, PRHO,
     +     NLPPA, AIC, LAGMAX+1, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP,
     +     LAGLST, .TRUE., YMISS, .FALSE., .FALSE., 0, NDUM, NDUM, 0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   30H       CALL ACFM (Y, YMISS, N))
      END
*ACFMN
      SUBROUTINE ACFMN(Y, N, LAGMAX, RHO, SDRHO, YMEAN, PRHO, AIC,
     +   FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA, CHIAP, WORK,
     +   NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND
C     PARTIAL AUTOCORRELATIONS OF A 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 21, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN
      INTEGER
     +   IAR,LACOV,LAGMAX,LAIC,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),AIC(*),FTEST(2,*),PHI(*),PRHO(*),RHO(*),SDRHO(*),
     +   WORK(*),Y(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFSD,ACVF,AOS,CHIRHO
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR.
C     REAL AIC(LAIC)
C        THE ARRAY CONTAINING AKAIAES CRITERION FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     REAL FTEST(2, LAGMAX)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS MADE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR).
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER (IAR).
C     REAL PRHO(LAGMAX)
C        THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED
C     REAL RHO(LAGMAX)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED
C     REAL SDRHO(LAGMAX)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C     REAL WORK(LAGMAX)
C        AN ARRAY USED IN THE COMPUTATIONS OF THE PARTIAL
C        AUTOCORRELATIONS COEFFICIENTS.
C        ARE STORED
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     COMPUTE AUTOCOVARIANCESS AND STANDARD DEVIATION OF THE SERIES.
C
      CALL ACVF(Y, N, YMEAN, ACOV, LAGMAX, LACOV)
C
      IF (ACOV(1) .EQ. 0.0E0) RETURN
C
C     COMPUTE PARTIAL AUTOCORRELATIONS AND THE AUTOREGRESSIVE MODEL
C     ORDER SELECTION STATISTICS.
C
      CALL AOS (N, LAGMAX, ACOV, PRHO, IAR, OSPVAR, PHI, WORK,
     +   AIC, FTEST, LACOV, LAIC)
C
      IF (NPRT .EQ. 0) RETURN
C
C     COMPUTE AUTOCORRELATIONS
C
      DO 10 I = 1, LAGMAX
         RHO(I) = ACOV(I+1) / ACOV(1)
   10 CONTINUE
C
C     COMPUTE STANDARD ERROR OF AUTOCORRELATIONS.
C
      CALL ACFSD (RHO, SDRHO, LAGMAX, N)
C
C     COMPUTE CHI STATISTIC BASED ON AUTOCORRELATION VALUES
C
      CALL CHIRHO (RHO, N, LAGMAX, CHIA, CHIAP)
C
      RETURN
      END
*ACFMNF
      SUBROUTINE ACFMNF (YFFT, N, NFFT, LAGMAX, RHO, SDRHO, YMEAN,
     +   PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC,
     +   CHIA, CHIAP, LYFFT, WORK, LWORK, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND
C     PARTIAL AUTOCORRELATIONS OF A 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 21, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN
      INTEGER
     +   IAR,LACOV,LAGMAX,LAIC,LWORK,LYFFT,N,NFFT,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),AIC(*),FTEST(2,*),PHI(*),PRHO(*),RHO(*),SDRHO(*),
     +   WORK(*),YFFT(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFSD,ACVFF,AOS,CHIRHO
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR.
C     REAL AIC(LAIC)
C        THE AKAIKES INFORMATION CRITERION VECTOR.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     REAL FTEST(2, LAGMAX)
C        THE ARRAY IN WHICH THE PARTIAL F RATIOS AND PROBABILITIES
C        ARE STORED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS MADE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE.
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER (IAR).
C     REAL PRHO(LAGMAX)
C        THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED
C     REAL RHO(LAGMAX)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED
C     REAL SDRHO(LAGMAX)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C     REAL WORK(LWORK)
C        A WORK ARRAY.
C     REAL YFFT(LYFFT)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     COMPUTE AUTOCOVARIANCESS AND STANDARD DEVIATION OF THE SERIES.
C
      CALL ACVFF(YFFT, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV, LYFFT, WORK,
     +   LWORK)
C
      IF (ACOV(1) .EQ. 0.0E0) RETURN
C
C     COMPUTE PARTIAL AUTOCORRELATIONS AND AUTOREGRESSIVE ORDER
C     SELECTION STATISTICS.
C
      CALL AOS (N, LAGMAX, ACOV, PRHO, IAR, OSPVAR, PHI, WORK,
     +   AIC, FTEST, LACOV, LAIC)
C
      IF (NPRT .EQ. 0) RETURN
C
C     COMPUTE AUTOCORRELATIONS
C
      DO 10 I = 1, LAGMAX
         RHO(I) = ACOV(I+1) / ACOV(1)
   10 CONTINUE
C
C     COMPUTE STANDARD ERROR OF AUTOCORRELATIONS.
C
      CALL ACFSD (RHO, SDRHO, LAGMAX, N)
C
C     COMPUTE CHI STATISTIC BASED ON AUTOCORRELATION VALUES
C
      CALL CHIRHO (RHO, N, LAGMAX, CHIA, CHIAP)
C
      RETURN
      END
*ACFMNM
      SUBROUTINE ACFMNM(Y, YMISS, N, LAGMAX, RHO, SDRHO, NLPPA, YMEAN,
     +   PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA,
     +   CHIAP, LAGLST, WORK, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND
C     PARTIAL AUTOCORRELATIONS OF A TIME SERIES WITH MISSING DATA.
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
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YMISS
      INTEGER
     +   IAR,LACOV,LAGLST,LAGMAX,LAIC,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),AIC(*),FTEST(2,*),PHI(*),PRHO(*),RHO(*),SDRHO(*),
     +   WORK(*),Y(*)
      INTEGER
     +   NLPPA(*)
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,NUSED
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFSDM,ACVFM,AOS,CHIRHO
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR.
C     REAL AIC(LAIC)
C        THE ARRAY CONTAINING AKAIAES CRITERION FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL FTEST(2, LAGMAX)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGLST
C        THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF THE
C        SERIES NOT TO BE COMPUTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER NLPPA(LACOV)
C        THE ARRAY CONTAINING THE NUMBERS OF LAGGED PRODUCT PAIRS
C        USED TO COMPUTE THE ACVF AT EACH LAG.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS MADE.
C     INTEGER NUSED
C        THE NUMBER OF ACTIVE (NOT MISSING) OBSERVATIONS IN THE SERIES.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR).
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER (IAR).
C     REAL PRHO(LAGMAX)
C        THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED
C     REAL RHO(LAGMAX)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED
C     REAL SDRHO(LAGMAX)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C     REAL WORK(LAGMAX)
C        AN ARRAY USED IN THE COMPUTATIONS OF THE PARTIAL
C        AUTOCORRELATIONS COEFFICIENTS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER
C        OR NOT AN OBSERVATION IN THE SERIES IS MISSING.
C        IF Y(I) .EQ. YMISS, THE VALUE IS ASSUMED MISSING.
C        IF Y(I) .NE. YMISS, THE VALUE IS ASSUMED NOT MISSING.
C
C
      FPLM = R1MACH(2)
C
C     COMPUTE AUTOCOVARIANCES OF THE SERIES WITH MISSING DATA.
C
      CALL ACVFM(Y, YMISS, N, YMEAN, ACOV, LAGMAX, LAGLST, NLPPA, LACOV)
C
      IF (NLPPA(1) .EQ. 0 .OR. ACOV(1) .EQ. 0.0E0) RETURN
C
      IF (NPRT .EQ. 0) RETURN
C
C     COMPUTE PARTIAL AUTOCORRELATIONS AND THE AUTOREGRESSIVE MODEL
C     ORDER SELECTION STATISTICS IF THERE WERE NO MISSING DATA.
C
      IF (NLPPA(1) .EQ. N) CALL AOS (N, LAGMAX, ACOV, PRHO, IAR,
     +   OSPVAR, PHI, WORK, AIC, FTEST, LACOV, LAIC)
C
C     COMPUTE AUTOCORRELATIONS.
C
      DO 10 I = 1, LAGMAX
         IF (NLPPA(I+1) .GE. 1) RHO(I) = ACOV(I+1) / ACOV(1)
   10 CONTINUE
C
C     PRESET SDRHO VALUES FOR PRINTING ROUTINE
C
      DO 20 I = LAGLST, LAGMAX
         SDRHO(I) = FPLM
   20 CONTINUE
C
C     COMPUTE STANDARD ERROR OF AUTOCORRELATIONS.
C
      CALL ACFSDM (RHO, SDRHO, LAGLST, N, NLPPA(2))
C
      IF (LAGLST .EQ. 0) RETURN
C
C     COMPUTE CHI STATISTIC BASED ON AUTOCORRELATION VALUES
C
      NUSED = NLPPA(1)
C
      CALL CHIRHO (RHO, NUSED, LAGLST, CHIA, CHIAP)
C
      RETURN
      END
*ACFMS
      SUBROUTINE ACFMS (Y, YMISS, N, LAGMAX, LACOV, ACOV, AMISS, NLPPA,
     +   NPRT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO-
C     CORRELATIONS OF A TIME SERIES WITH MISSING VALUES (LONG CALL).
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
      REAL
     +   AMISS,YMISS
      INTEGER
     +   LACOV,LAGMAX,LDSTAK,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),Y(*)
      INTEGER
     +   NLPPA(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   CHIA,CHIAP,FPLM,OSPVAR,YMEAN,YSD
      INTEGER
     +   AIC,FTEST,I,IAR,IFP,IPRT,LAGLST,LDSMIN,LYFFT,NALL0,NFAC,
     +   NFFT,PHI,PRHO,SDRHO,WORK
      LOGICAL
     +   DIFFER,ISFFT
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   IOD(1),ND(1),NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      INTEGER
     +   STKGET,STKST
      EXTERNAL R1MACH,STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFER,ACFMNM,ACFOUT,IPRINT,LDSCMP,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE VECTOR.
C     INTEGER AIC
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER.
C     REAL AMISS
C        THE MISSING VALUE CODE FOR THE RETURNED ACVF ESTIMATES
C        (VECTOR ACOV).
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE)
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER FTEST
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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     INTEGER IFP
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING
C        POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION.
C     INTEGER IOD(1)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGLST
C        THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF THE
C        SERIES NOT TO BE COMPUTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER ND(1)
C        THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED
C     INTEGER NDUM(1)
C        A DUMMY ARRAY.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NLPPA(LACOV)
C        THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS
C        USED TO COMPUTE EACH ACVF ESTIMATE.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS MADE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR).
C     INTEGER PHI
C        THE STARTING LOCATION IN DSTAK FOR THE
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     INTEGER PRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR PRHO.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR SDRHO.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR WORK.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER
C        OR NOT AN OBSERVATION IN THE SERIES IS MISSING.
C        IF Y(I) .EQ. YMISS, THE VALUE IS ASSUMED MISSING.
C        IF Y(I) .NE. YMISS, THE VALUE IS ASSUMED NOT MISSING.
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'A',       'C',       'F',       'M',       'S',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      DIFFER = .FALSE.
      NFAC = 1
      ND(1) = 0
      IOD(1) = 0
      ISFFT = .FALSE.
      LYFFT = N
      NFFT = N
C
      IF (NPRT .EQ. 0) THEN
        LDSMIN = 0
      ELSE
        CALL LDSCMP(5, 0, 0, 0, 0, 0, 'S', 6*LAGMAX+1, LDSMIN)
      END IF
C
      CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET(LDSTAK, 4)
        NALL0 = STKST(1)
C
        FPLM = R1MACH(2)
C
        AMISS = FPLM
C
        IF (NPRT.EQ.0) THEN
C
C         SPECIFY STARTING LOCATIONS IN THE STACK FOR DUMMY VARIABLES
C
          PRHO = 1
          AIC = 1
          FTEST = 1
          PHI = 1
          WORK = 1
          SDRHO = 1
        ELSE
C
          IFP = 3
C
          PRHO = STKGET(LAGMAX, IFP)
          AIC = STKGET(LAGMAX+1, IFP)
          FTEST = STKGET(2*LAGMAX, IFP)
          PHI = STKGET(LAGMAX, IFP)
          WORK = STKGET(LAGMAX, IFP)
          SDRHO = WORK
        END IF
C
        IF (IERR.EQ.0) THEN
C
C         CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
          CALL ACFMNM (Y, YMISS, N, LAGMAX, ACOV(2), RSTAK(SDRHO),
     +       NLPPA, YMEAN, RSTAK(PRHO), RSTAK(AIC), RSTAK(FTEST),
     +       RSTAK(PHI), IAR, OSPVAR, ACOV, LACOV, LAGMAX+1, CHIA,
     +       CHIAP, LAGLST, RSTAK(WORK), NPRT)
C
          IF (LAGLST .GE. 0) THEN
            YSD = SQRT (ACOV(1) * N / (N - 1))
          ELSE
            YSD = ACOV(1)
          END IF
C
C           CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
          IF ((NPRT.NE.0) .OR. (ACOV(1).EQ.0.0E0))
     +      CALL ACFOUT (YMEAN, YSD, N, NLPPA(1), LAGMAX, ACOV(2),
     +         RSTAK(SDRHO), RSTAK(PRHO), NLPPA, RSTAK(AIC), LAGMAX+1,
     +         RSTAK(FTEST), IAR, RSTAK(PHI), OSPVAR, CHIA, CHIAP,
     +         LAGLST, .TRUE., YMISS, .FALSE., .FALSE., 0, NDUM, NDUM,
     +         0)
C
          IF (NPRT.NE.0) THEN
            DO 50 I = 1, LAGMAX
               ACOV(I+1) = ACOV(I+1) * ACOV(1)
   50       CONTINUE
          END IF
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL ACFMS (Y, YMISS, N,'/
     +  '      +            LAGMAX, LACOV, ACOV, AMISS, NLPPA, NPRT,',
     +  ' LDSTAK)')
      END
*ACFOUT
      SUBROUTINE ACFOUT (YMEAN, YSD, N, NUSED, LAGMAX, RHO, SDRHO,
     +   PRHO, NLPPA, AIC, LAIC, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP,
     +   NDFCHI, IFMISS, YMISS, DIFFER, NEWPG, NFAC, ND, IOD, NTIMES)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE AUTOCORRELATIONS AND THEIR
C     STANDARD ERRORS, AS WELL AND THE PARTIAL AUTOCORRELATIONS
C     AND MISCELLANEOUS SUMMARY INFORMATION.
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
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YMISS,YSD
      INTEGER
     +   IAR,LAGMAX,LAIC,N,NDFCHI,NFAC,NTIMES,NUSED
      LOGICAL
     +   DIFFER,IFMISS,NEWPG
C
C  ARRAY ARGUMENTS
      REAL
     +   AIC(LAIC),FTEST(2,LAGMAX),PHI(LAGMAX),PRHO(LAGMAX),
     +   RHO(LAGMAX),SDRHO(LAGMAX)
      INTEGER
     +   IOD(*),ND(*),NLPPA(LAGMAX)
C
C  LOCAL SCALARS
      REAL
     +   FPLM,PMISS
      INTEGER
     +   IPRT,NMISS
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFDTL,ACFLST,AOSLST,IPRINT,VERSP,VPMN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AIC(LAIC)
C        THE ARRAY CONTAINING THE AKAIKES INFORMATION CRITERION.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE VARIABLE USED TO DESIGNATE WHETHER OR NOT THE SERIES
C        ANALYZED WAS DIFFERENCED OR NOT.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL FTEST(2, LAGMAX)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     LOGICAL IFMISS
C        THE INDICATOR VARIABLE USED TO DETERMINE
C        WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT.
C     INTEGER IOD(NFAC)
C        THE ORDER OF EACH OF THE DIFFERENCING FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED
C        OUTPUT.
C     INTEGER ISYM(1)
C        A DUMMY ARRAY.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER ND(NFAC)
C        THE ARRAY CONTANING THE NUMBER OF TIMES THE DIFFERENCING
C        FACTORS ARE TO BE APPLIED.
C     INTEGER NDFCHI
C        THE DEGREES OF FREEDOM FOR THE CHI SQUARED STATISTIC.
C     LOGICAL NEWPG
C        THE VARIABLE DESIGNATING WHETHER OR NOT THE OUTPUT IS TO
C        START ON A NEW PAGE.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS.
C     INTEGER NLPPA(LAGMAX)
C        THE ARRAY OF NUMBERS OF LAGGED PRODUCT PAIRS USED TO
C        COMPUTE EACH ACF ESTIMATE.
C     INTEGER NMISS
C        THE NUMBER OF MISSING OBSERVATIONS.
C     INTEGER NTIMES
C        THE NUMBER OF TIMES THE FIRST DIFFERENCE FACTOR HAS BEEN
C        APPLIED.
C     INTEGER NUSED
C        THE ACTIVE NUMBER OF OBSERVATIONS.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR).
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     REAL PMISS
C        THE PERCENT OF MISSING OBSERVATIONS.
C     REAL PRHO(LAGMAX)
C        THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED
C     REAL RHO(LAGMAX)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED
C     REAL SDRHO(LAGMAX)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED SERIES.
C     REAL YMISS, YMMISS(1)
C        THE MISSING VALUE CODE.
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVED SERIES.
C
C
      FPLM = R1MACH(2)
C
      YMMISS(1) = FPLM
C
C     PRINT SUMMARY INFORMATION
C
      CALL IPRINT(IPRT)
C
      IF (NEWPG) WRITE(IPRT, 1004)
C
      CALL VERSP (.TRUE.)
      WRITE(IPRT, 1005)
      IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES)
      WRITE(IPRT, 1000) YMEAN, YSD, N
      IF (.NOT. IFMISS) GO TO 10
      NMISS = N - NUSED
      PMISS = 100.0E0 * NMISS / N
      WRITE(IPRT, 1003) NMISS, PMISS
   10 WRITE(IPRT, 1006) LAGMAX
      IF (IFMISS) WRITE(IPRT, 1007) YMISS
C
      IF (YSD .GT. 0.0E0) GO TO 20
C
      WRITE (IPRT, 1010)
      RETURN
C
   20 CONTINUE
C
C     PRINT ACF INFORMATION
C
      WRITE(IPRT, 1008)
      WRITE(IPRT, 1001)
      CALL ACFLST (RHO, SDRHO, NLPPA, LAGMAX, IFMISS, CHIA, NDFCHI,
     +   CHIAP)
C
C     PLOT ACF INFORMATION
C
      WRITE(IPRT, 1004)
      CALL VERSP (.TRUE.)
      WRITE(IPRT, 1001)
      IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES)
      CALL VPMN(RHO, YMMISS, LAGMAX, 1, LAGMAX, 1, 0, ISYM, 1, 0,
     +   -1.0E0, 1.0E0, 1.0E0, 1.0E0, IFMISS, 0, 0, 1)
C
C     CHECK WHETHER PACF HAVE BEEN COMPUTED
C
      IF (NUSED .LE. N-1) RETURN
C
C     PRINT PACF INFORMATION AND AUTOREGRESSIVE MODEL ORDER SELECTION
C     STATISTICS
C
      WRITE(IPRT, 1004)
      CALL VERSP (.TRUE.)
      WRITE(IPRT, 1002)
      WRITE (IPRT, 1009)
      IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES)
      CALL AOSLST (PRHO, AIC, FTEST, LAGMAX, LAIC, IAR, PHI, OSPVAR,
     +   .TRUE., N)
C
C     PLOT PACF INFORMATION
C
      WRITE(IPRT, 1004)
      CALL VERSP (.TRUE.)
      WRITE(IPRT, 1002)
      IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES)
      CALL VPMN(PRHO, YMMISS, NDFCHI, 1, NDFCHI, 1, 0, ISYM, 1, 0,
     +   -1.0E0, 1.0E0, 1.0E0, 1.0E0, IFMISS, 0, 0, 1)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/
     +   ' AVERAGE OF THE SERIES                 = ', G14.7/
     +   ' STANDARD DEVIATION OF THE SERIES      = ', G14.7/
     +   ' NUMBER OF TIME POINTS                 = ', I10)
 1001 FORMAT (40H AUTOCORRELATION FUNCTION ESTIMATE (ACF)/)
 1002 FORMAT (49H PARTIAL AUTOCORRELATION FUNCTION ESTIMATE (PACF)/)
 1003 FORMAT (
     +   ' NUMBER OF MISSING OBSERVATIONS        = ', I10/
     +   ' PERCENTAGE OF OBSERVATIONS MISSING    = ', F10.4)
 1004 FORMAT ('1')
 1005 FORMAT ( 25H AUTOCORRELATION ANALYSIS)
 1006 FORMAT(
     +   ' LARGEST LAG VALUE USED                = ', I10)
 1007 FORMAT(
     +   ' MISSING VALUE CODE                    = ', G14.7)
 1008 FORMAT(//)
 1009 FORMAT (46H AND AUTOREGRESSIVE ORDER SELECTION STATISTICS///)
 1010 FORMAT (///36H THE AUTOCORRELATIONS OF THIS SERIES,
     +   22H COULD NOT BE COMPUTED/
     +   50H BECAUSE THE LAG ZERO AUTOCOVARIANCE OF THE SERIES,
     +    9H IS ZERO.)
      END
*ACFSD
      SUBROUTINE ACFSD (RHO, SDRHO, NC, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE STANDARD ERROR OF THE AUTOCORRELATIONS
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
     +   N,NC
C
C  ARRAY ARGUMENTS
      REAL
     +   RHO(*),SDRHO(*)
C
C  LOCAL SCALARS
      INTEGER
     +   K,KLAST,LAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,REAL,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER KLAST
C        THE LAST LAG VALUE TO BE USED.
C     INTEGER LAG
C        THE INDEX VARIABLE USED TO INDICATE THE AUTOCORRELATION
C        BEING EXAMINED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NC
C        THE NUMBER OF AUTOCORRELATIONS COMPUTED
C     REAL RHO(NC)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED
C     REAL SDRHO(NC)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C
      SDRHO(1) = SQRT(REAL(N - 1)) / N
      IF (NC .EQ. 1) RETURN
      DO 20 LAG = 2, NC
         SDRHO(LAG) = 0.0E0
         KLAST = MIN(LAG-1, N-LAG)
         DO 10 K = 1, KLAST
            SDRHO(LAG) = SDRHO(LAG) + (N-LAG-K) * RHO(K) * RHO(K)
   10    CONTINUE
         SDRHO(LAG) = SQRT((N-LAG) + 2.0E0 * SDRHO(LAG)) / N
   20 CONTINUE
      RETURN
      END
*ACFSDM
      SUBROUTINE ACFSDM (RHO, SDRHO, NC, N, NLPPA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE STANDARD ERROR OF THE AUTOCORRELATIONS
C     WHEN MISSING DATA ARE INVOLVED.
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
     +   N,NC
C
C  ARRAY ARGUMENTS
      REAL
     +   RHO(*),SDRHO(*)
      INTEGER
     +   NLPPA(*)
C
C  LOCAL SCALARS
      INTEGER
     +   K,KLAST,LAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,REAL,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER KLAST
C        THE LAST LAG VALUE TO BE USED.
C     INTEGER LAG
C        THE INDEX VARIABLE USED TO INDICATE THE AUTOCORRELATION
C        BEING EXAMINED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NC
C        THE NUMBER OF AUTOCORRELATIONS COMPUTED
C     INTEGER NLPPA(NC)
C        THE ARRAY IN WHICH THE NUMBER OF OBSERVATIONS USED TO
C        COMPUTE EACH AUTOCORRELATION AND PARTIAL AUTOCORRELATION
C        IS STORED
C     REAL RHO(NC)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED
C     REAL SDRHO(NC)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C
      SDRHO(1) = SQRT(REAL(NLPPA(1))) * (N-1) / (N * NLPPA(1))
      IF (NC .EQ. 1) RETURN
      DO 20 LAG = 2, NC
         SDRHO(LAG) = 0.0E0
         KLAST = MIN(LAG-1, N-LAG)
         DO 10 K = 1, KLAST
            SDRHO(LAG) = SDRHO(LAG) + (N-LAG-K) * RHO(K) * RHO(K)
   10    CONTINUE
         SDRHO(LAG) = SQRT((N-LAG) + 2.0E0 * SDRHO(LAG)) *
     +      (N-LAG) / (N*NLPPA(LAG))
   20 CONTINUE
      RETURN
      END
*ACFS
      SUBROUTINE ACFS(Y, N, LAGMAX, LACOV, ACOV, IAR, PHI, NPRT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO-
C     CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES
C     WITH THE COMPUTED ACVF ESTIMATES RETURNED TO THE USERS
C     ROUTINE (LONG CALL).
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
     +   IAR,LACOV,LAGMAX,LDSTAK,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),PHI(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   CHIA,CHIAP,OSPVAR,YMEAN,YSD
      INTEGER
     +   AIC,FTEST,I,IFP,IPRT,LDSMIN,LYFFT,NALL0,NFAC,NFFT,PRHO,
     +   SDRHO,WORK
      LOGICAL
     +   DIFFER,ISFFT
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   IOD(1),ND(1),NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACFER,ACFMN,ACFOUT,IPRINT,LDSCMP,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE VECTOR.
C     INTEGER AIC
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER.
C     REAL CHIA, CHIAP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS
C        ARE STORED.
C     LOGICAL DIFFER
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE)
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER FTEST
C        THE STARTING LOCATION IN DSTAK FOR
C        THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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     INTEGER IFP
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING
C        POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION.
C     INTEGER IOD(1)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C     INTEGER ND(1)
C        THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED
C     INTEGER NDUM(1)
C        A DUMMY DIMENSIONED VARIABLE.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS MADE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR).
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     INTEGER PRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR PRHO.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHO
C        THE STARTING LOCATION IN THE WORK AREA FOR SDRHO.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR WORK.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'A',       'C',       'F',       'S',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      DIFFER = .FALSE.
      NFAC = 1
      ND(1) = 0
      IOD(1) = 0
      ISFFT = .FALSE.
      LYFFT = N
      NFFT = N
C
C
      CALL LDSCMP(4, 0, 0, 0, 0, 0, 'S', 5*LAGMAX+1, LDSMIN)
C
      CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN,
     +  DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET(LDSTAK, 4)
        NALL0 = STKST(1)
C
        IFP = 3
C
        PRHO = STKGET(LAGMAX, IFP)
        AIC = STKGET(LAGMAX+1, IFP)
        FTEST = STKGET(2*LAGMAX, IFP)
        WORK = STKGET(LAGMAX, IFP)
        SDRHO = WORK
C
        IF (IERR.EQ.0) THEN
C
C         CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
          CALL ACFMN (Y, N, LAGMAX, ACOV(2), RSTAK(SDRHO),
     +       YMEAN, RSTAK(PRHO), RSTAK(AIC), RSTAK(FTEST), PHI,
     +       IAR, OSPVAR, ACOV, LACOV, LAGMAX+1, CHIA, CHIAP,
     +       RSTAK(WORK), NPRT)
C
          YSD = SQRT (ACOV(1) * N / (N - 1))
C
C         CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
          IF ((NPRT.NE.0) .OR.  (ACOV(1).EQ.0.0E0)) CALL ACFOUT
     +       (YMEAN, YSD, N, N, LAGMAX, ACOV(2), RSTAK(SDRHO),
     +       RSTAK(PRHO), NDUM, RSTAK(AIC), LAGMAX+1, RSTAK(FTEST),
     +       IAR, PHI, OSPVAR, CHIA, CHIAP, LAGMAX, .FALSE., 0.0E0,
     +       .FALSE., .FALSE., 0, NDUM, NDUM, 0)
C
          IF (NPRT.NE.0) THEN
            DO 50 I = 1, LAGMAX
               ACOV(I+1) = ACOV(I+1) * ACOV(1)
   50       CONTINUE
          END IF
C
        END IF
C
        CALL STKCLR(NALL0)
C
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL ACFS (Y, N,'/
     + '      +           LAGMAX, LACOV, ACOV, IAR, PHI, NPRT, LDSTAK)')
      END
*ACVF
      SUBROUTINE ACVF (Y, N, YMEAN, ACOV, LAGMAX, LACOV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE AUTOCOVARIANCE FUNCTION OF A SERIES.
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
      REAL
     +   YMEAN
      INTEGER
     +   LACOV,LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),Y(*)
C
C  LOCAL SCALARS
      REAL
     +   DOTXY,DOTYY
      INTEGER
     +   LAG,NDOTXY,NDOTYY
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,DOTC
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED
C     REAL DOTXY, DOTYY
C        THE DOT PRODUCT BETWEEN VECTORS (Y(I) - YMEAN)) AND
C        (Y(LAG) - YMEAN)), AND (Y(I) - YMEAN)) AND (Y(I) - YMEAN)),
C        RESPECTIVELY.
C     INTEGER LACOV
C        THE ACTUAL DIMENSION OF ACOV.
C     INTEGER LAG, LAGMAX
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        AUTOCOVARIANCE BEING COMPUTED AND THE MAXIMUM LAG TO BE USED,
C        RESPECTIVELY.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NDOTXY, NDOTYY
C        THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY AND
C        DOTYY, RESPECTIVELY.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     COMPUTE ARITHMETIC MEAN
C
      CALL AMEAN(Y, N, YMEAN)
C
C     COMPUTE THE VARIANCE OF THE SERIES Y
C
      CALL DOTC (Y, YMEAN, N, Y, YMEAN, N, DOTYY, NDOTYY)
      ACOV(1) = DOTYY / NDOTYY
C
C     COMPUTE AUTOCOVARIANCES.
C
      DO 10 LAG = 1, LAGMAX
         CALL DOTC (Y, YMEAN, N, Y(LAG+1), YMEAN, N - LAG,
     +       DOTXY, NDOTXY)
         ACOV(LAG + 1) = DOTXY / N
   10 CONTINUE
C
      RETURN
      END
*ACVFF
      SUBROUTINE ACVFF (YFFT, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV,
     +   LYFFT, WORK, LWORK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE ACVF OF A SERIES USING TWO
C     PASSES OF A FFT.
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
      REAL
     +   YMEAN
      INTEGER
     +   LACOV,LAGMAX,LWORK,LYFFT,N,NFFT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),WORK(*),YFFT(*)
C
C  LOCAL SCALARS
      REAL
     +   FAC
      INTEGER
     +   I,ISN,N1,NF,NFFT2
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,FFT,FFTCT,REALTR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED
C     REAL FAC
C        A FACTOR USED IN THE COMPUTATIONS.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER ISN
C        AN INDICATOR VARIABLE USED BY THE FFT ROUTINES.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG TO BE USED.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NF
C        THE NUMBER OF FOURIER FREQUENCIES.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NFFT2
C        THE EFFECTIVE NUMBER OF OBSERVATIONS FOR THE FFT TRANSFORM.
C     INTEGER N1
C        THE VALUE N + 1.
C     REAL WORK(LWORK)
C        THE WORK AREA FOR THE COMPUTATIONS.
C     REAL YFFT(LYFFT)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     COMPUTE ARITHMETIC MEAN
C
      CALL AMEAN(YFFT, N, YMEAN)
C
C     SUBTRACT THE MEAN FROM THE SERIES
C
      DO 10 I = 1, N
         YFFT(I) = YFFT(I) - YMEAN
   10 CONTINUE
C
C     APPEND ZEROS
C
      N1 = N + 1
C
      DO 20 I = N1, NFFT
         YFFT(I) = 0.0E0
   20 CONTINUE
C
C     COMPUTE AUTOCOVARIANCES.
C
      ISN = 2
      NFFT2 = (NFFT - 2)/ 2
C
      CALL FFT(YFFT(1), YFFT(2), NFFT2, NFFT2, NFFT2, ISN)
      CALL REALTR (YFFT(1), YFFT(2), NFFT2, ISN)
C
      NF = NFFT2 + 1
C
      DO 30 I = 1, NF
         WORK(I) = YFFT(2*I-1)*YFFT(2*I-1) + YFFT(2*I)*YFFT(2*I)
   30 CONTINUE
C
      CALL FFTCT (WORK, NFFT2, LWORK)
C
      FAC = 1.0E0 / (4 * (NFFT - 2) * N)
C
      ACOV(1) = WORK(1) * FAC
C
      DO 40 I = 1, LAGMAX
         ACOV(I+1) = WORK(I+1) * FAC
   40 CONTINUE
C
      RETURN
      END
*ACVFM
      SUBROUTINE ACVFM (Y, YMISS, N, YMEAN, ACOV, LAGMAX,
     +   LAGLST, NLPPA, LACOV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE AUTOCOVARIANCES WHEN MISSING DATA 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  -  NOVEMBER 21, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YMEAN,YMISS
      INTEGER
     +   LACOV,LAGLST,LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),Y(*)
      INTEGER
     +   NLPPA(*)
C
C  LOCAL SCALARS
      REAL
     +   DOTXY,DOTYY,FPLM
      INTEGER
     +   LAG,NDOTXY,NDOTYY,NUSED
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      INTEGER
     +   LSTLAG
      EXTERNAL R1MACH,LSTLAG
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEANM,DOTCM
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED
C     REAL DOTXY, DOTYY
C        THE DOT PRODUCT BETWEEN VECTORS (Y(I) - YMEAN)) AND
C        (Y(LAG) - YMEAN)), AND (Y(I) - YMEAN)) AND (Y(I) - YMEAN)),
C        RESPECTIVELY.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAG, LAGLST, LAGMAX
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        AUTOCORRELATION BEING COMPUTED, THE NUMBER OF AUTOCORRELATIONS
C        COMPUTED BEFORE A MISSING AUTOCORRELATION, AND THE NUMBER OF
C        AUTOCORRELATIONS DESIRED, RESPECTIVELY.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NDOTXY, NDOTYY
C        THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY AND
C        DOTYY, RESPECTIVELY.
C     INTEGER NLPPA(LACOV)
C        THE ARRAY CONTAINING THE NUMBERS OF LAGGED PRODUCT PAIRS
C        USED TO COMPUTE THE ACVF AT EACH LAG.
C     INTEGER NUSED
C        THE NUMBER OF ACTIVE OBSERVATIONS IN THE SERIES.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IN THE SERIES IS MISSING.  IF Y(I) = YMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C
C
      FPLM = R1MACH(2)
C
C     COMPUTE ARITHMETIC MEAN, WITH MISSING VALUES TAKEN INTO ACCOUNT
C
      CALL AMEANM (Y, YMISS, N, NUSED, YMEAN)
C
C     COMPUTE THE VARIANCE OF THE SERIES Y
C
      CALL DOTCM (Y, YMEAN, YMISS, N, Y, YMEAN, YMISS, N,
     +   DOTYY, NDOTYY)
      NLPPA(1) = NDOTYY
      IF (NLPPA(1).EQ.0) THEN
         LAGLST = 0
      ELSE
         ACOV(1) = DOTYY / NDOTYY
C
C     COMPUTE AUTOCORRELATIONS, WITH MISSING VALUES TAKEN INTO ACCOUNT
C
         DO 10 LAG = 1, LAGMAX
            CALL DOTCM (Y, YMEAN, YMISS, N, Y(LAG+1), YMEAN,
     +         YMISS, N - LAG, DOTXY, NDOTXY)
            NLPPA(LAG + 1) = NDOTXY
            ACOV(LAG + 1) = FPLM
            IF (NLPPA(LAG + 1) .LE. 0) GO TO 10
            ACOV(LAG + 1) = DOTXY * (N-LAG) / (NLPPA(LAG + 1) * N)
   10    CONTINUE
C
C     FIND THE LAST AUTOCORRELATION TO BE COMPUTED BEFORE
C     ONE COULD NOT BE COMPUTED DUE TO MISSING DATA
C
         LAGLST = LSTLAG(NLPPA, LAGMAX, LACOV)
      END IF
      RETURN
      END
*ADJLMT
      SUBROUTINE ADJLMT(YMN, YMX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CORRECTS THE PLOT LIMITS WHEN ALL
C     OBSERVATIONS ARE IDENTICALLY EQUAL.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YMN,YMX
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL YMN, YMX
C        THE Y-AXIS LOWER AND UPPER LIMITS ACTUALLY USED.
C
      write ( *, * ) 'DEBUG: ADJLMT'
      write ( *, * ) 'YMN = ', ymn
      write ( *, * ) 'YMX = ', ymx
      IF (YMN .LT. YMX) RETURN
C
C     CORRECT FOR ALL OBSERVATIONS IDENTICALLY EQUAL
C
      YMN = YMN - ABS(YMN/2.0E0)
      YMX = YMX + ABS(YMX/2.0E0)
      IF (YMN .LT. YMX) RETURN
      YMN = -0.5E0
      YMX = 0.5E0

      write ( *, * ) 'DEBUG: ADJLMT'
      write ( *, * ) 'Done now'
      RETURN
      END
*AIME
      SUBROUTINE AIME (Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK)
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
     +   LDSTAK,N,NFAC,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),Y(*)
      INTEGER
     +   MSPEC(4,*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,MIT,
     +   NPARE,NPRT
      LOGICAL
     +   SAVE
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SCALE(1),SDPV(1),SDRES(1),STP(1),VCV(1,1)
      INTEGER
     +   IFIXED(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEDRV,IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        THE PREDICTED VALUE OF THE FIT, UNUSED WHEN SAVE = FALSE.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL 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     REAL SCALE(1)
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     REAL SDPV(1)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES, UNUSED
C        WHEN SAVE = FALSE.
C     REAL SDRES(1)
C        THE STANDARDIZED RESIDUALS, UNUSED WHEN SAVE = FALSE.
C     REAL 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     REAL 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     REAL STP(1)
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     REAL VCV(1,1)
C        THE VARIANCE-COVARIANCE MATRIX, UNUSED WHEN SAVE = FALSE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'A','I','M','E',' ',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SAVE = .FALSE.
C
      LIFIXD = 1
      IFIXED(1) = -1
      LSTP = 1
      STP(1) = 0.0E0
      MIT = -1
      STOPSS = -1.0E0
      STOPP = -1.0E0
      LSCALE = 1
      SCALE(1) = 0.0E0
      DELTA = -1.0E0
      IVAPRX = -1
      NPRT = -1
      LPV = 1
      LSDPV = 1
      LSDRES = 1
      IVCV = 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
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
C
 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'//
     +  '       CALL AIME (Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK)')
      END
*AIMEC
      SUBROUTINE AIMEC(Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK,
     +   IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT)
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
      REAL
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IVAPRX,LDSTAK,MIT,N,NFAC,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),SCALE(*),STP(*),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
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,NPARE
      LOGICAL
     +   SAVE
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SDPV(1),SDRES(1),VCV(1,1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEDRV,IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        THE PREDICTED VALUE OF THE FIT, UNUSED WHEN SAVE = FALSE.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL 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     REAL 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     REAL SDPV(1)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES, UNUSED
C        WHEN SAVE = FALSE.
C     REAL SDRES(1)
C        THE STANDARDIZED RESIDUALS, UNUSED WHEN SAVE = FALSE.
C     REAL 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     REAL 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     REAL STP(1)
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     REAL VCV(1,1)
C        THE VARIANCE-COVARIANCE MATRIX, UNUSED WHEN SAVE = FALSE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'A','I','M','E','C',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SAVE = .FALSE.
C
      LIFIXD = NPAR
      IF (IFIXED(1).LE.-1) LIFIXD = 1
      LPV = 1
      LSCALE = NPAR
      IF (SCALE(1).LE.0.0E0) LSCALE = 1
      LSTP = NPAR
      IF (STP(1).LE.0.0E0) LSTP = 1
      LSDPV = 1
      LSDRES = 1
      IVCV = 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
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'//
     +  '       CALL AIMEC (Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK,'/
     +  '      +            IFIXED, STP, MIT, STOPSS, STOPP, SCALE,'/
     +  '      +            DELTA, IVAPRX, NPRT)')
      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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IVCV,LDSTAK,MIT,N,NFAC,NPAR,NPARE,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   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
     +   IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP
      LOGICAL
     +   SAVE
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEDRV,IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(N)
C        THE PREDICTED VALUE OF THE FIT.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL 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     REAL 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     REAL SDPV(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL 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     REAL 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     REAL VCV(IVCV,NPAR)
C        THE VARIANCE-COVARIANCE MATRIX.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
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.0E0) LSCALE = 1
      LSTP = NPAR
      IF (STP(1).LE.0.0E0) 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
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'//
     +  '       CALL 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)')
      END
*AIMF
      SUBROUTINE AIMF (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR ARIMA ESTIMATION
C     (SHORT 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
     +   LDSTAK,N,NFAC,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),Y(*)
      INTEGER
     +   MSPEC(4,*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IFCST,IPRT,NFCST,NFCSTO,NPRT
      LOGICAL
     +   SAVE
C
C  LOCAL ARRAYS
      REAL
     +   FCST(1,1),FCSTSD(1)
      INTEGER
     +   IFCSTO(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMFCNT,IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FCST(1,1)
C        THE STORAGE ARRAY FOR THE FORECASTS.
C     REAL FCSTSD(1)
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(1)
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     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     REAL 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     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'A','I','M','F',' ',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SAVE = .FALSE.
C
      NFCST = N/10 + 1
      NFCSTO = 1
      IFCSTO(1) = N
      NPRT = -1
      IFCST = 1
C
      CALL AMFCNT(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK, NFCST, NFCSTO,
     +   IFCSTO, NPRT, FCST, IFCST, FCSTSD, NMSUB, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'//
     +     '       CALL AIMF (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK)')
      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
      REAL
     +   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
     +   IPRT,NFCSTU
      LOGICAL
     +   SAVE
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMFCNT,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FCST(IFCST,NFCSTO)
C        THE STORAGE ARRAY FOR THE FORECASTS.
C     REAL 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     REAL 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     REAL Y(N)
C        THE DEPENDENT VARIABLE.
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
      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
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'//
     +  '       CALL AIMFS (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK,'/
     +  '      +            NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST,',
     +  ' FCSTSD)')
      END
*AIMX1
      SUBROUTINE AIMX1(MXN, MXPAR, MXFC, MXFCO, MXFAC,
     +   MOD, N, MSPEC, NFAC, PAR, NPAR, RES,
     +   IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT,
     +   NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV,
     +   NFCST, NFCSTO, IFCSTO, FCST, IFCST, FCSTSD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     SET THE STARTING PARAMETER VALUES FOR AIMX
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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IFCST,IVAPRX,IVCV,MIT,MOD,MXFAC,MXFC,MXFCO,MXN,MXPAR,N,
     +   NFAC,NFCST,NFCSTO,NPAR,NPARE,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FCST(MXFC,*),FCSTSD(*),PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),
     +   SDRES(*),STP(*),VCV(MXPAR,*)
      INTEGER
     +   IFCSTO(*),IFIXED(*),MSPEC(4,*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   SQMEPS
      INTEGER
     +   I,J
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RMDCON
      EXTERNAL RMDCON
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SETRV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELTA
C        THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     REAL FCST(MXFC,MXFCO)
C        THE FORECASTS.
C     REAL FCSTSD(MXFC)
C        THE STANDARD DEVIATION OF THE FORECASTS.
C     INTEGER I
C        *
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 IFCST
C        *
C     INTEGER IFCSTO(MXFCO)
C        THE FORECAST ORIGINS.
C     INTEGER IFIXED(MXPAR)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(I).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
C     INTEGER IVAPRX
C        *
C     INTEGER IVCV
C        THE ACTUAL FIRST DIMENSION OF VCV.
C     INTEGER J
C        *
C     INTEGER MIT
C        *
C     INTEGER MOD
C        AN INDICATOR VALUE USED TO DESIGNATE THE MODEL FOR WHICH
C        THE PARAMETERS ARE TO BE SET.
C     INTEGER MSPEC(4,MXFAC)
C        THE VALUES OF P, D, Q AND S FOR EACH FACTOR.
C     INTEGER MXFAC
C        THE MAXIMUM NUMBER OF FACTORS ALLOWED.
C     INTEGER MXFC
C        THE MAXIMUM NUMBER OF FORECASTS ALLOWED.
C     INTEGER MXFCO
C        THE MAXIMUM NUMBER OF FORECASTS ORIGINS ALLOWED.
C     INTEGER MXN
C        THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED.
C     INTEGER MXPAR
C        THE MAXIMUM NUMBER OF PARAMETERS ALLOWED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NFCST, NFCSTO
C        THE NUMBER OF FORECASTS AND FORCAST ORIGINS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C        TO BE PROVIDED.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS ESTIMATED BY THE ROUTINE.
C     INTEGER NPRT
C        *
C     REAL PAR(MXPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PV(MXN)
C        THE PREDICTED VALUES.
C     REAL RES(MXN)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL SCALE(MXPAR)
C        THE SCALE VALUES.
C     REAL SDPV(MXN)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUES.
C     REAL SDRES(MXN)
C        THE STANDARDIZED RESIDUALS.
C     REAL SQMEPS, STOPP, STOPSS
C        *
C     REAL STP(MXPAR)
C        THE STEP VALUES.
C     REAL VCV(MXPAR,MXPAR)
C        THE VARIANCE COVARIANCE MATRIX.
C
      GO TO (10, 20, 30, 40, 50, 60), MOD
C
   10 CONTINUE
      N = 144
      NFAC = 2
      MSPEC(1,1) = 0
      MSPEC(2,1) = 1
      MSPEC(3,1) = 1
      MSPEC(4,1) = 1
      MSPEC(1,2) = 0
      MSPEC(2,2) = 1
      MSPEC(3,2) = 1
      MSPEC(4,2) = 12
      NPAR = 3
      PAR(1) = 0.0E0
      PAR(2) = 0.4E0
      PAR(3) = 0.6E0
      IFIXED(1) = 1
      IFIXED(2) = 0
      IFIXED(3) = 0
C
      GO TO 70
C
C
   20 PAR(1) = 1.0E0
      PAR(2) = 2.0E0
      PAR(3) = 3.0E0
C
      GO TO 70
C
C
   30 PAR(1) = 6.0E0
      PAR(2) = 5.0E0
      PAR(3) = 4.0E0
      PAR(4) = 3.0E0
      PAR(5) = 2.0E0
C
      GO TO 70
C
C
   40 CALL SETRV(PAR, NPAR, 0.0E0)
C
      GO TO 70
C
C
   50 CALL SETRV(PAR, NPAR, 0.5E0)
C
      GO TO 70
C
C
   60 PAR(1) = 100.0E0
      PAR(2) = 15.0E0
C
   70 CONTINUE
C
      SQMEPS = SQRT(RMDCON(3))
C
      MIT = 25
      DO 80 I=1,10
         STP(I) = SQMEPS
         SCALE(I) = 1.0E0
   80 CONTINUE
      STOPSS = 10.0E-7
      STOPP = 10.0E-7
      DELTA = 0.5E0
      NPRT = 11111
      IVAPRX = 3
      IVCV = MXPAR
C
      NFCST = 36
      NFCSTO = 2
      IFCSTO(1) = 103
      IFCSTO(2) = N
      IFCST = MXFC
C
      DO 85 I=1,MXN
         RES(I) = -1.0E0
         PV(I) = -1.0E0
         SDPV(I) = -1.0E0
         SDRES(I) = -1.0E0
   85 CONTINUE
C
      DO 100 I=1,MXPAR
         DO 90 J=1,MXPAR
            VCV(I,J) = -1.0E0
   90    CONTINUE
  100 CONTINUE
C
      DO 110 I = 1, MXFC
        FCSTSD(I) = -1.0E0
        DO 105 J = 1, MXFCO
          FCST(I,J) = -1.0E0
  105   CONTINUE
  110 CONTINUE
C
      NPARE = -1
      RSD = -1.0E0
C
      IERR = -1
C
      RETURN
C
      END
*ALBETA
      REAL FUNCTION ALBETA (A, B)
C JULY 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL A,B
C
C  LOCAL SCALARS
      REAL CORR,P,Q,SQ2PIL
C
C  EXTERNAL FUNCTIONS
      REAL ALNGAM,ALNREL,GAMMA,R9LGMC
      EXTERNAL ALNGAM,ALNREL,GAMMA,R9LGMC
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG,MAX,MIN
C
      DATA SQ2PIL / 0.91893853320467274E0 /
C
      P = MIN (A, B)
      Q = MAX (A, B)
C
      IF (P.LE.0.0) CALL XERROR (
     1  'ALBETA  BOTH ARGUMENTS MUST BE GT ZERO', 38, 1, 2)
      IF (P.GE.10.0) GO TO 30
      IF (Q.GE.10.0) GO TO 20
C
C P AND Q ARE SMALL.
C
      ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) )
      RETURN
C
C P IS SMALL, BUT Q IS BIG.
C
 20   CORR = R9LGMC(Q) - R9LGMC(P+Q)
      ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) +
     1  (Q-0.5)*ALNREL(-P/(P+Q))
      RETURN
C
C P AND Q ARE BIG.
C
 30   CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q)
      ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q))
     1  + Q*ALNREL(-P/(P+Q))
      RETURN
C
      END
*ALGAMS
      SUBROUTINE ALGAMS (X, ALGAM, SGNGAM)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C EVALUATE LOG ABS (GAMMA(X)) AND RETURN THE SIGN OF GAMMA(X) IN SGNGAM.
C SGNGAM IS EITHER +1.0 OR -1.0.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL ALGAM,SGNGAM,X
C
C  EXTERNAL FUNCTIONS
      REAL ALNGAM
      EXTERNAL ALNGAM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT,MOD
C
      ALGAM = ALNGAM(X)
      SGNGAM = 1.0
      IF (X.GT.0.0) RETURN
C
C     INT = AMOD (-AINT(X), 2.0) + 0.1
      IF (INT(MOD(-INT(X),2)+0.1).EQ.0) SGNGAM = -1.0
C
      RETURN
      END
*ALNGAM
      REAL FUNCTION ALNGAM (X)
C JUNE 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
C
C  LOCAL SCALARS
      REAL DXREL,PI,SINPIY,SQ2PIL,SQPI2L,XMAX,Y
C
C  EXTERNAL FUNCTIONS
      REAL GAMMA,R1MACH,R9LGMC
      EXTERNAL GAMMA,R1MACH,R9LGMC
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,AINT,LOG,SIN,SQRT
C
      DATA SQ2PIL / 0.9189385332 0467274E0/
C SQ2PIL = LOG(SQRT(2.*PI)),  SQPI2L = LOG (SQRT(PI/2.))
      DATA SQPI2L / 0.2257913526 4472743E0/
      DATA PI     / 3.1415926535 8979324E0/
C
      DATA XMAX, DXREL / 0., 0. /
C
      IF (XMAX.NE.0.) GO TO 10
      XMAX = R1MACH(2)/LOG(R1MACH(2))
      DXREL = SQRT (R1MACH(4))
C
 10   Y = ABS(X)
      IF (Y.GT.10.0) GO TO 20
C
C LOG (ABS (GAMMA(X))) FOR  ABS(X) .LE. 10.0
C
      ALNGAM = LOG (ABS (GAMMA(X)))
      RETURN
C
C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0
C
 20   IF (Y.GT.XMAX) CALL XERROR (
     1  'ALNGAM  ABS(X) SO BIG ALNGAM OVERFLOWS', 38, 2, 2)
C
      IF (X.GT.0.0) THEN
         ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y)
         RETURN
      END IF
C
      SINPIY = ABS (SIN(PI*Y))
      IF (SINPIY.EQ.0.) CALL XERROR ('ALNGAM  X IS A NEGATIVE INTEGER',
     1  31, 3, 2)
C
      IF (ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL XERROR (
     1    'ALNGAM  ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE
     2INTEGER', 68, 1, 1)
C
      ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y)
      RETURN
C
      END
*ALNREL
      REAL FUNCTION ALNREL (X)
C APRIL 1977 VERSION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
C
C  LOCAL SCALARS
      REAL XMIN
      INTEGER NLNREL
C
C  LOCAL ARRAYS
      REAL ALNRCS(23)
C
C  EXTERNAL FUNCTIONS
      REAL CSEVL,R1MACH
      INTEGER INITS
      EXTERNAL CSEVL,R1MACH,INITS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG,SQRT
C
C SERIES FOR ALNR       ON THE INTERVAL -3.75000D-01 TO  3.75000D-01
C                                        WITH WEIGHTED ERROR   1.93E-17
C                                         LOG WEIGHTED ERROR  16.72
C                               SIGNIFICANT FIGURES REQUIRED  16.44
C                                    DECIMAL PLACES REQUIRED  17.40
C
      DATA ALNRCS( 1) /   1.0378693562 743770E0 /
      DATA ALNRCS( 2) /   -.1336430150 4908918E0 /
      DATA ALNRCS( 3) /    .0194082491 35520563E0 /
      DATA ALNRCS( 4) /   -.0030107551 12753577E0 /
      DATA ALNRCS( 5) /    .0004869461 47971548E0 /
      DATA ALNRCS( 6) /   -.0000810548 81893175E0 /
      DATA ALNRCS( 7) /    .0000137788 47799559E0 /
      DATA ALNRCS( 8) /   -.0000023802 21089435E0 /
      DATA ALNRCS( 9) /    .0000004164 04162138E0 /
      DATA ALNRCS(10) /   -.0000000735 95828378E0 /
      DATA ALNRCS(11) /    .0000000131 17611876E0 /
      DATA ALNRCS(12) /   -.0000000023 54670931E0 /
      DATA ALNRCS(13) /    .0000000004 25227732E0 /
      DATA ALNRCS(14) /   -.0000000000 77190894E0 /
      DATA ALNRCS(15) /    .0000000000 14075746E0 /
      DATA ALNRCS(16) /   -.0000000000 02576907E0 /
      DATA ALNRCS(17) /    .0000000000 00473424E0 /
      DATA ALNRCS(18) /   -.0000000000 00087249E0 /
      DATA ALNRCS(19) /    .0000000000 00016124E0 /
      DATA ALNRCS(20) /   -.0000000000 00002987E0 /
      DATA ALNRCS(21) /    .0000000000 00000554E0 /
      DATA ALNRCS(22) /   -.0000000000 00000103E0 /
      DATA ALNRCS(23) /    .0000000000 00000019E0 /
C
      DATA NLNREL, XMIN /0, 0./
C
      IF (NLNREL.NE.0) GO TO 10
      NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3))
      XMIN = -1.0 + SQRT(R1MACH(4))
C
 10   IF (X.LE.(-1.0)) CALL XERROR (
     1  'ALNREL  X IS LE -1', 18, 2, 2)
      IF (X.LT.XMIN) CALL XERROR (
     1  'ALNREL  ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 54,
     2  1, 1)
C
      IF (ABS(X).LE.0.375) THEN
         ALNREL = X*(1.0-X*CSEVL(X/0.375,ALNRCS,NLNREL))
      ELSE
         ALNREL = LOG (1.0+X)
      END IF
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
      REAL
     +   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
      REAL
     +   PJ,STPJ
      INTEGER
     +   I,J,JPK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SIGN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PJ
C        A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER.
C     REAL RESTS(NRESTS)
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     REAL SCL(LSCL)
C        THE SCALE VALUES.
C     REAL STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     REAL 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
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)

        write ( *, * ) 'DEBUG: SCL(JPK) = ', scl(jpk)
        write ( *, * ) 'DEBUG: STPT(J)  = ', stpt(j)
        write ( *, * ) 'DEBUG: PAR(J) =   ', par(j)
         IF (SCL(JPK).NE.0.0E0) THEN
            STPJ = STPT(J)*SIGN(1.0E0,PAR(J))*MAX(ABS(PAR(J)),1.0E0/
     +             ABS(SCL(JPK)))
         ELSE
            IF (PAR(J).NE.0.0E0) THEN
               STPJ = STPT(J)*SIGN(1.0E0,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
*AMEAN
      SUBROUTINE AMEAN(Y, N, YMEAN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE ARITHMETIC MEAN OF A SERIES.
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
      REAL
     +   YMEAN
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  LOCAL SCALARS
      REAL
     +   SUMY
      INTEGER
     +   I
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     REAL SUMY
C        THE VARIABLE USED TO SUM THE Y VALUES.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
      SUMY = 0.0E0
      DO 10 I = 1, N
         SUMY = SUMY + Y(I)
   10 CONTINUE
      YMEAN = SUMY / N
      RETURN
      END
*AMEANM
      SUBROUTINE AMEANM (Y, YMISS, N, NUSED, YMEAN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE ARITHMETIC MEAN OF A SERIES WHEN MISSING
C     DATA ARE 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
      REAL
     +   YMEAN,YMISS
      INTEGER
     +   N,NUSED
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  LOCAL SCALARS
      REAL
     +   SUMY
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      EXTERNAL MVCHK
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NUSED
C        THE NUMBER OF ACTIVE NUMBER OF OBSERVATIONS.
C     REAL SUMY
C        THE VARIABLE USED TO SUM THE NON-MISSING Y VALUES.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IS MISSING.  IF Y(I) = YMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C
      NUSED = 0
      SUMY = 0.0E0
      DO 10 I = 1, N
         IF (MVCHK(Y(I), YMISS)) GO TO 10
         SUMY = SUMY + Y(I)
         NUSED = NUSED + 1
   10 CONTINUE
      IF (NUSED.GE.1) THEN
         YMEAN = SUMY / NUSED
      ELSE
         YMEAN = SUMY
      END IF
      RETURN
      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
      REAL
     +   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
      REAL
     +   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
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEMN,CPYASF,CPYVII,SCOPY,SETIV,STKCLR
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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     REAL 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 REAL 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     REAL 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     REAL 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     REAL 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     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER RWORK
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE REAL 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     REAL SCALE(LSCALE)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL 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     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     INTEGER SDRESI
C        THE STARTING LOCATION IN RWORK OF THE
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL 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     REAL STP(LSTP)
C        THE STEP SIZE ARRAY.
C     REAL 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET VARIOUS PROGRAM VALUES
C
      NALL0 = STKST(1)
C
      IFP = 3
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 SCOPY(N, RSTAK(PVI), 1, PV, 1)
      CALL SCOPY(N, RSTAK(SDPVI), 1, SDPV, 1)
      CALL SCOPY(N, RSTAK(SDRESI), 1, SDRES, 1)
      CALL CPYASF(NPARE, RSTAK(VCVL), LVCVL, VCV, IVCV)
C
   10 CALL STKCLR(NALL0)
C
      RETURN
C
      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
      REAL
     +   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
      REAL
     +   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
      REAL
     +   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
      REAL
     +   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,SCOPY,
     +   STKCLR,STKSET,STPAMO
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
      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     REAL 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     REAL 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     REAL 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     REAL PV(LPV)
C        THE PREDICTED VALUE OF THE FIT.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSTAK(12)
C        THE REAL 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     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL 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     REAL 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     REAL 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     REAL WT(1)
C        THE USER SUPPLIED WEIGHTS, UNUSED WHEN WEIGHT = FALSE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C     SET VARIOUS PROGRAM VALUES
C
      WEIGHT = .FALSE.
      WT(1) = 1.0E0
      LWT = 1
C
      HLFRPT = .FALSE.
      APRXDV = .TRUE.
      PRTFXD = .TRUE.
      EXMPT = -1.0E0
      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.0E0) IS = 1
C
      CALL LDSCMP(25, 0, MAX(IS*2*(N+NPAR),60+NPAR+NPARE) + 4*NFAC,
     +   0, 0, 0, 'S', 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 = 3
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 SCOPY(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.0E0) 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)

      write ( *, * ) 'DEBUG: RSTAK(STPT)=', rstak(stpt)
      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
   10 CONTINUE
C
      CALL STKCLR(NALL0)
C
      RETURN
C
      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
      REAL
     +   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
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     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL STP(LSTP)
C        THE STEP SIZE ARRAY.
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.0E0, 0, HEAD, 6, NV,
     +      ERROR(8), LZERO)
          CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 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
*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
      REAL
     +   RSD,RSSHLF
      INTEGER
     +   IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE,NRESTS
      LOGICAL
     +   PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   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
      REAL
     +   COND,RSS,YSS
      INTEGER
     +   I,IDF
      LOGICAL
     +   EXACT,PRTFSM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEOUT,NLCMP
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL COND
C        THE CONDITION NUMBER OF D.
C     REAL 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     REAL 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     REAL PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     REAL RD(N)
C        THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R
C        FACTORIZATION OF D.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL RSSHLF
C        HALF THE RESIDUAL SUM OF SQUARES.
C     REAL SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C     REAL YSS
C        THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE.
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
*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
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT, 1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT, 1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT ('+NONLINEAR LEAST SQUARES ESTIMATION',
     +   ' FOR THE PARAMETERS OF AN ARIMA MODEL, CONTINUED')
 1010 FORMAT ('+', 77(1H*)/
     +   1X, 37H*  NONLINEAR LEAST SQUARES ESTIMATION,
     +   40H FOR THE PARAMETERS OF AN ARIMA MODEL  */
     +   2H *, 16X, 45H             USING BACKFORECASTS             ,
     +   14X, 1H*/1X, 77(1H*))
 1020 FORMAT ('1')
 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-'))
      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
      REAL
     +   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
      REAL
     +   RSD,RSS
      INTEGER
     +   IAMHD,IPRT,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   SNRM2
      EXTERNAL SNRM2
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMLST,IPRINT,MODSUM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC REAL,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     REAL 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     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     INTEGER RFCTOL
C        THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE
C        TOLERANCE.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL RWORK(LRWORK)
C        WORK SPACE USED BY THE NL2 SUBROUTINES.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL 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
      DATA MXFCAL/17/, MXITER/18/
C
C     RWORK SUBSCRIPT VALUES
C
      DATA LMAX0/35/, RFCTOL/32/, XCTOL/33/
C
      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) WRITE (IPRT, 1170) NNZW
      WRITE(IPRT, 1070) IWORK(MXITER)
      WRITE(IPRT, 1090) IWORK(MXFCAL)
      WRITE(IPRT, 1080)
      WRITE(IPRT, 1100) RWORK(RFCTOL)
      WRITE(IPRT, 1110) RWORK(XCTOL)
      WRITE(IPRT, 1120) RWORK(LMAX0)
      RSD = SNRM2(NRESTS, RES, 1)
      RSS = RSD * RSD
      IF (N-NPARDF-NPARE.GE.1)
     +     RSD = RSD / SQRT(REAL(N-NPARDF-NPARE))
      WRITE (IPRT, 1200) RSS
      WRITE (IPRT, 1210) RSD
      WRITE (IPRT, 1220) N, NPARDF, NPARE, NNZW-NPARE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1070 FORMAT (/37H MAXIMUM NUMBER OF ITERATIONS ALLOWED, 32X, 5H(MIT),
     +   1X, I5)
 1080 FORMAT(/44H CONVERGENCE CRITERION FOR TEST BASED ON THE/)
 1090 FORMAT(/' MAXIMUM NUMBER OF MODEL SUBROUTINE CALLS',
     +   8H ALLOWED, 26X, I5)
 1100 FORMAT (5X, 39H FORECASTED RELATIVE CHANGE IN RESIDUAL,
     +   15H SUM OF SQUARES, 7X, 8H(STOPSS), 1X, G11.4)
 1110 FORMAT(5X, 49H MAXIMUM SCALED RELATIVE CHANGE IN THE PARAMETERS,
     +   13X, 7H(STOPP), 1X, G11.4)
 1120 FORMAT(//' MAXIMUM CHANGE ALLOWED IN THE PARAMETERS',
     +   23H AT THE FIRST ITERATION, 3X, 7H(DELTA), 1X, G11.4)
 1170 FORMAT (/' NUMBER OF NON ZERO WEIGHTED OBSERVATIONS', 27X,
     +   6H(NNZW), 1X, I5)
 1200 FORMAT (/44H RESIDUAL SUM OF SQUARES FOR INPUT PARAMETER,
     +   7H VALUES, 24X, G11.4, '  (BACKFORECASTS INCLUDED)')
 1210 FORMAT (/48H RESIDUAL STANDARD DEVIATION FOR INPUT PARAMETER,
     +   7H VALUES, 14X, 5H(RSD), 1X, G11.4)
 1220 FORMAT (/ 19H BASED ON DEGREES O,
     +   9HF FREEDOM, 1X, I4, 3H - , I3, 3H - , I3, 3H = , I4)
      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
      REAL
     +   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
      REAL
     +   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,SCOPY
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
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     REAL D(NRESTS,NPAR)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
C     REAL 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 REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL 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     REAL 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     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL 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     REAL 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     REAL RWORK(IRWORK)
C        THE REAL 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     REAL 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     REAL 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     REAL 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     REAL 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
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 SCOPY(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
*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
      REAL
     +   COND,RSD,RSS,YSS
      INTEGER
     +   IDF,IVCVPT,LVCVL,N,NDIGIT,NPAR,NPARE
      LOGICAL
     +   EXACT,PAGE,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   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
      REAL
     +   FPLM
      INTEGER
     +   I,IAMHD,IPRT,ISUBHD
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEPT1,AMEPT2,AMLST,IPRINT,MODSUM,NLSKL,VCVOTF
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
      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     REAL 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     REAL 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     REAL 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     REAL PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL 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     REAL 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     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C     REAL YSS
C        THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE.
C
C
      FPLM = R1MACH(2)
C
      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
   10 IF (IPTOUT(4).EQ.0) GO TO 20
      ISUBHD = 0
      CALL AMEHDR(PAGE, WIDE, ISUBHD)
C
      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)
      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 WRITE (IPRT,1000)
      IAMHD = 3
      CALL AMLST(IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, VCVL, LVCVL,
     +   PAR, NPAR, PAR, NPAR, IFIXD, RSS, RSD, NPARDF, NPARE, IDF)
      WRITE (IPRT,1050) COND
C
      IF (RSS.GT.YSS) WRITE (IPRT,1060)
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) WRITE (IPRT,1080)
      WRITE (IPRT,1000)
      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) WRITE (IPRT,1050) COND
C
      IF ((IERR.EQ.0) .AND. (.NOT.EXACT) .AND. (IDF.LE.0)) WRITE
     +   (IPRT,1070)
      IF ((IERR.EQ.0) .AND. EXACT) WRITE (IPRT,1090)
C
      IF (IERR.NE.0) GO TO 100
C
      DO 90 I=1,N
         SDREST(I) = 0.0E0
         SDPVT(I) = 0.0E0
   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
 1000 FORMAT (///33H ESTIMATES FROM LEAST SQUARES FIT/1X, 33('-'))
 1050 FORMAT (/29H APPROXIMATE CONDITION NUMBER, 10X, G15.7)
 1060 FORMAT (//52H THE RESIDUAL SUM OF SQUARES AFTER THE LEAST SQUARES,
     +   20H FIT IS GREATER THAN/35H THE SUM OF SQUARES ABOUT THE MEAN ,
     +   19HY OBSERVATION.  THE, 14H MODEL IS LESS/17H REPRESENTATIVE O,
     +   39HF THE DATA THAN A SIMPLE AVERAGE.  DATA, 15H AND MODEL SHOU,
     +   2HLD/48H BE CHECKED TO BE SURE THAT THEY ARE COMPATABLE.)
 1070 FORMAT (/49H THE DEGREES OF FREEDOM FOR THIS PROBLEM IS ZERO.,
     +   54H  STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.)
 1080 FORMAT (//40H THE FOLLOWING SUMMARY SHOULD BE USED TO, 8H ANALYZE,
     +   30H THE ABOVE MENTIONED PROBLEMS.)
 1090 FORMAT (/50H THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS,
     +   35H EXACT TO WITHIN MACHINE PRECISION./20H STATISTICAL ANALYSI,
     +   33HS OF THE RESULTS IS NOT POSSIBLE.)
      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
      REAL
     +   PVT(*),RES(*),SDPVT(*),SDREST(*),Y(*)
      INTEGER
     +   IPTOUT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,IPRT,NMAX
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,OBSSM2
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
      FPLM = R1MACH(2)
C
      CALL IPRINT(IPRT)
C
      WRITE (IPRT,1100)
      WRITE (IPRT,1000)
      WRITE (IPRT, 1110)
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 (IPRT, 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)) WRITE (IPRT, 1080)
      IF ((IERR.GT.0) .AND. (IERR.NE.4)) WRITE (IPRT, 1090)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/ 5X, 16X, '  -----PREDICTED  ----STD DEV OF', 16X,
     +   '  ---STD'/
     +   2X, 3HROW, '  --------SERIES  ---------VALUE',
     +   '  ----PRED VALUE  ------RESIDUAL  ---RES')
 1080 FORMAT (// 37H *  NC  -  VALUE NOT COMPUTED BECAUSE,
     +   48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.)
 1090 FORMAT (// 29H *  NC  -  VALUE NOT COMPUTED,
     +   54H BECAUSE CONVERGENCE PROBLEMS PREVENTED THE COVARIANCE,
     +   28H MATRIX FROM BEING COMPUTED.)
 1100 FORMAT (//' RESULTS FROM LEAST SQUARES FIT'/ 1X, 31('-'))
 1110 FORMAT (' ')
 1150 FORMAT (4X, '.', 4(15X, '.'), 7X, '.')
      END
*AMEPT2
      SUBROUTINE AMEPT2 (RES, SDREST, N, RSS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE, ADAPTED FROM OMNITAB II, PRINTS
C     THE FOUR STANDARDIZED RESIDUAL PLOTS.
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
      REAL
     +   RSS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   RES(*),SDREST(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   AN,DOT,FAC1,FAC2,FPLM,GAMMA,PI,RATIO,ROWDIV,ROWMAX,ROWMID,
     +   ROWMIN,XDIV,XMAX,XMIN,YLABEL,YMAX,YMIN
      INTEGER
     +   I,I1,I2,IMID,IPLOT,IPRB,IPRT,IROW,IX,K,L,NCOL,NCOLP1,
     +   NCOLPL,NCOLT2,NDOT,NROW
      CHARACTER
     +   IBLANK*1,IMINUS*1,IPLUS*1,ISTAR*1
C
C  LOCAL ARRAYS
      CHARACTER
     +   LINE(113)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      LOGICAL
     +   MVCHK
      EXTERNAL R1MACH,MVCHK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DOTC,GETPI,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT,MAX,MIN,MOD
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AN
C        THE NUMBER OF OBSERVATIONS, USED IN COMPUTING
C        THE NORMAL PROBABILITY PLOT.
C     REAL DOT
C        THE DOT PRODUCT USED TO COMPUTE THE CORRELATION COEFFICIENT.
C     REAL FAC1, FAC2
C        FACTORS USED IN COMPUTING THE NORMAL PROBABILITY PLOT.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL GAMMA
C        A VALUE USED IN COMPUTING THE NORMAL PROBABILITY PLOT.
C     INTEGER I
C        AN INDEX VARIABLE.
C     CHARACTER*1 IBLANK
C        THE VALUE OF THE CHARACTER -BLANK-.
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 IMID
C        THE MIDPOINT OF THE AUTOCORRELATION PLOT.
C     CHARACTER*1 IMINUS
C        THE CHARACTER MINUS.
C     INTEGER IPLOT
C        AN INDICATOR VARIABLE DESIGNATING WHETHER THE FIRST OR
C        SECOND SET OF TWO PLOTS ARE BEING PRINTED.
C     CHARACTER*1 IPLUS
C        THE CHARACTER PLUS.
C     INTEGER IPRB
C        THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE
C        PROBABILITY PLOT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IROW
C        THE ROW OF THE VARIABLES BEING PLOTTED.
C     CHARACTER*1 ISTAR
C        THE CHARACTER STAR.
C     INTEGER IX
C        THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE PLOTS
C        VERSUS THE INDEPENDENT VARIABLE.
C     INTEGER I1, I2
C        INDEX VALUES.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER L
C        AN INDEX VARIABLE.
C     CHARACTER*1 LINE(113)
C        THE SYMBOLS (BLANKS AND CHARACTERS) FOR A GIVEN LINE
C        OF THE PLOT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NCOL, NCOLPL, NCOLP1, NCOLT2
C        THE NUMBER OF COLUMNS IN THE PLOT, NCOL+L, NCOL+1,
C        AND NCOL * 2.
C     INTEGER NDOT
C        THE NUMBER OF POINTS MAKING UP DOT.
C     INTEGER NROW
C        THE NUMBER OF COLUMNS IN THE PLOT.
C     REAL PI
C        THE VALUE OF PI.
C     REAL RATIO
C        A VALUE USED TO PRODUCE THE NORMAL PROBABILITY PLOT.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL ROWDIV
C        THE VALUE OF A DIVISION ALONG THE -ROW- AXIS.
C     REAL ROWMAX
C        THE LARGEST ROW VALUE.
C     REAL ROWMID
C        THE MIDPOINT OF THE RANGE OF THE ROWS PLOTTED.
C     REAL ROWMIN
C        THE SMALLEST ROW VALUE PLOTTED.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL XDIV
C        THE VALUE OF A DIVISION ALONG THE X AXIS.
C     REAL XMAX
C        THE LARGEST VALUE ALONG THE X AXIS.
C     REAL XMIN
C        THE SMALLEST VALUE ALONG THE X AXIS.
C     REAL YLABEL
C        THE LABEL TO BE PRINTED ALONG THE Y AXIS.
C     REAL YMAX
C        THE LARGEST VALUE ALONG THE Y AXIS
C     REAL YMIN
C        THE SMALLEST VALUE ALONG THE Y AXIS.
C
      DATA IPLUS/'+'/, IMINUS/'-'/, ISTAR/'*'/, IBLANK/' '/
C
      CALL IPRINT(IPRT)
C
      FPLM = R1MACH(2)
C
C     CHECK FOR INSUFFICIENT POINTS TO PLOT
C
      IF (IERR.NE.4) GO TO 20
      DO 10 I = 1, N
         IF (SDREST(I).NE.FPLM) GO TO 20
   10 CONTINUE
      WRITE (IPRT, 1090)
      RETURN
C
   20 CONTINUE
C
C     INITIALIZE VALUES FOR PROBABILITY PLOT
C
      CALL GETPI(PI)
      GAMMA = PI/8.0E0
      AN = N
      FAC1 = 1.0E0 / (AN - 2.0E0*GAMMA + 1.0E0)
      FAC2 = 10.0E0
C
C     INITIALIZE THE PLOT SIZE (IN PLOT UNITS)
C
      NROW = 26
C
C     BEGIN COMPUTATIONS FOR FIRST SET OF PLOTS
C
      IPLOT = 1
      NCOL = 111
C
C     SET X AXIS LIMITS FOR STANDARDIZED RESIDUAL VS ROW PLOT,
C
      ROWMIN = 1
      ROWMAX = N
C
      ROWMID = (ROWMAX+ROWMIN)/2.0E0
      ROWDIV = (ROWMAX-ROWMIN)/(NCOL-1)
C
C     PRINT TITLES FOR FIRST PLOTS
C
      WRITE (IPRT,1000)
      GO TO 90
C
C     BEGIN COMPUTATIONS FOR SECOND SET OF PLOTS
C
   40 IPLOT = 2
      NCOL = 51
C
C     SET AXIS LIMITS FOR THE STANDARDIZED RESIDUALS VS
C     STANDARDIZED RESIDUALS LAGGED BY ONE AND FOR PROBABILITY PLOT
C
      XMIN = -3.75E0
      XMAX = 3.75E0
      XDIV = (XMAX-XMIN)/(NCOL-1)
C
C     PRINT TITLES FOR SECOND PLOTS
C
      WRITE (IPRT,1050)
C
C     WRITE FIRST LINE OF PLOTS
C
   90 CONTINUE
C
C     PRINT PLOTS, ONE LINE AT A TIME
C
      NCOLP1 = NCOL + 1
      NCOLT2 = 2*NCOL
      YLABEL = 3.75E0
      YMAX = FPLM
      YMIN = 4.05E0
      DO 160 K=1,NROW
         YMIN = YMIN - 0.3E0
         IF (-3.70E0.GE.YMIN) YMIN = -FPLM
         DO 100 L=1,NCOL
            NCOLPL = L + NCOL
            LINE(L) = IBLANK
            IF (IPLOT.EQ.2) LINE(NCOLPL) = IBLANK
            IF ((K.NE.1) .AND. (K.NE.NROW)) GO TO 100
               LINE(L) = IMINUS
               IF (IPLOT.EQ.2) LINE(NCOLPL) = IMINUS
               IF ((MOD(L,10).NE.1) .AND. (L.NE.1+NCOL/2)) GO TO 100
                  LINE(L) = IPLUS
                  IF (IPLOT.EQ.2) LINE(NCOLPL) = IPLUS
  100    CONTINUE
         DO 130 I=1,N
            IF (.NOT.MVCHK(SDREST(I),FPLM)) THEN
               IF ((SDREST(I).GT.YMIN) .AND. (SDREST(I).LE.YMAX)) THEN
                  IF (IPLOT.EQ.1) THEN
                      IROW = INT(((I-ROWMIN)/ROWDIV)+1.5E0)
                      LINE(IROW) = ISTAR
                   ELSE
                      RATIO = (AN-GAMMA) * FAC1
                      IPRB = INT(4.91E0*(RATIO**0.14E0-
     +                          (1.0E0-RATIO)**0.14E0)*FAC2) + 77
                      IF (IPRB.LE.NCOL) IPRB = NCOL+1
                      IF (IPRB.GE.103) IPRB = 102
                      LINE(IPRB) = ISTAR
                      AN = AN - 1.0E0
                      IF ((AN.LT.2.0E0) .AND. (N.LE.10)) THEN
                         GAMMA = 1.0E0/3.0E0
                      END IF
                   END IF
                END IF
             END IF
  130    CONTINUE
C
C     SET PLOT LINE FOR CORRELATION PLOT OF SECOND SET OF PLOTS
C
         IF (IPLOT.EQ.2) THEN
            IMID = (NCOL-1)/2
            IF (K.LE.N-1) THEN
               DOT = 0.0E0
               CALL DOTC(RES, 0.0E0, N, RES(K+1), 0.0E0,
     +                   N-K, DOT, NDOT)
               IX = INT(IMID*DOT/RSS) + IMID + 1
               I1 = MIN(IX,IMID+1)
               I2 = MAX(IX,IMID+1)
               DO 135 IX=I1,I2
                  LINE(IX) = ISTAR
  135          CONTINUE
            END IF
         END IF
         IF (MOD(K,5).EQ.1) THEN
            IF (IPLOT.EQ.1) THEN
               WRITE (IPRT,2020) YLABEL, (LINE(L),L=1,NCOL)
            ELSE
               WRITE (IPRT,1020) K, (LINE(L),L=1,NCOL), YLABEL,
     +                           (LINE(L),L=NCOLP1,NCOLT2)
            END IF
            YLABEL = YLABEL - 1.5E0
         ELSE
            IF (IPLOT.EQ.1) THEN
               WRITE (IPRT,2030) (LINE(L),L=1,111)
            ELSE
               WRITE (IPRT,1030) (LINE(L),L=1,102)
            END IF
         END IF
         YMAX = YMIN
  160 CONTINUE
C
C     PRINT BOTTOM LINE OF GRAPHS
C
      IF (IPLOT.EQ.1) THEN
C
C     PRINT X AXIS LABELS FOR FIRST SET OF PLOTS
C
         WRITE (IPRT,1040) ROWMIN, ROWMID, ROWMAX
         GO TO 40
C
C     PRINT X AXIS LABELS FOR SECOND SET OF PLOTS
C
      ELSE
         WRITE (IPRT,1070)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/51X, 23H STD RES VS ROW NUMBER )
 1020 FORMAT (1X, I5, '+', 51A1, '+', 2X, F5.2, '+', 51A1, '+')
 1030 FORMAT (6X, '-', 51A1, '-', 7X, '-', 51A1, '-')
 1040 FORMAT (1X, F8.1, 47X, F8.1, 47X, F8.1)
 1050 FORMAT (/13X, 'AUTOCORRELATION FUNCTION OF RESIDUALS',
     +   23X, 36H NORMAL PROBABILITY PLOT OF STD RES )
 1070 FORMAT (4X, 5H-1.00, 22X, 3H0.0, 21X, 4H1.00, 5X, 4H-2.5, 23X,
     +   3H0.0, 22X, 3H2.5)
 1090 FORMAT (// 1X, 13(1H*)/ 1X, 13H*  WARNING  */ 1X, 13(1H*)//
     +   54H THE STANDARDIZED RESIDUAL PLOTS HAVE BEEN SUPPRESSED.,
     +   45H  NONE OF THE STANDARDIZED RESIDUALS COULD BE,
     +   10H COMPUTED,/
     +   50H BECAUSE FOR EACH OBSERVATION EITHER THE WEIGHT OR,
     +   48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.)
 2020 FORMAT (1X, F5.2, '+', 111A1, '+')
 2030 FORMAT (6X, '-', 111A1, '-')
      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
      REAL
     +   EXMPT
      INTEGER
     +   ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT,PVPAD
      LOGICAL
     +   HLFRPT,PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),SCALE(*),STP(*),XM(IXM,*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL HDR,MDL,STPOUT
C
C  SCALARS IN COMMON
      REAL
     +   Q
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      INTEGER
     +   STKGET,STKST
      EXTERNAL R1MACH,STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CPYVII,ETAMDL,SETIV,STKCLR,STPMN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,INT,LOG10,MAX,MIN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
      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     REAL ETA
C        THE RELATIVE NOISE IN THE MODEL.
C     REAL 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     REAL 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     REAL 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 REAL 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     REAL 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     REAL Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SCL
C        THE ACTUAL TYPICAL SIZE USED.
C     REAL STP(NPAR)
C        THE SELECTED STEP SIZES.
C     EXTERNAL STPOUT
C        THE ROUTINE FOR PRINTING THE OUTPUT.
C     REAL 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     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
C
      NALL0 = STKST(1)
C
      FPLRS = R1MACH(4)
      IFP = 3
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.0E0 ** (-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.25E0, 0.01E0)
C
      EXM = EXMPT
      IF ((EXM.LT.0.0E0) .OR. (EXM.GT.1.0E0)) EXM = 0.10E0
      NEXMPT = INT(EXM * N)
      IF (EXM .NE. 0.0E0) 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.0E0) THEN
            IF (PAR(J) .EQ. 0.0E0) THEN
               SCL = 1.0E0
            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))

        write ( *, * ) 'DEBUG: STPMN returns STP(J) = ', stp(j)
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
*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
      REAL
     +   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
      REAL
     +   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
      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     REAL FCST(IFCST,NFCSTO)
C        THE STORAGE ARRAY FOR THE FORECASTS.
C     REAL 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     REAL 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     REAL RSTAK(12)
C        THE REAL 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     REAL Y(N)
C        THE DEPENDENT VARIABLE.
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, 'S', 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 = 3
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
*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
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
*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
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT, 1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT, 1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT ('+ARIMA FORECASTING, CONTINUED')
 1010 FORMAT ('+', 23(1H*)/ ' *  ARIMA FORECASTING  *', /1X, 23(1H*))
 1020 FORMAT ('1')
 1030 FORMAT (//' MODEL SUMMARY'/' -------------')
      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
      REAL
     +   F(*),FCST(IFCST,*),FCSTSD(*),FSD(*),PAR(*),PARAR(*),PARDF(*),
     +   PARMA(*),PV(N1:N2),T(*),TEMP(*),Y(*)
      INTEGER
     +   IFCSTO(*),MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      REAL
     +   CONST,PMU,RSD,RSS,T975,WSUM,WSUMT
      INTEGER
     +   I,I1,IDF,IF,IFC,IFLAG,IFO,IFOMIN,IPRT,J,K,NT
      LOGICAL
     +   PAGE
C
C  EXTERNAL FUNCTIONS
      REAL
     +   PPFT,SDOT
      EXTERNAL PPFT,SDOT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMFHDR,AMFOUT,AMLST,DCOEF,IPRINT,MDLTS2,MODSUM,MULTBP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CONST
C        THE CONSTANT TERM IN THE MODEL, MODELING EITHER THE SERIES
C        MEAN OR A DETERMINISTIC TREND.
C     REAL F(NFCST)
C        THE FORECASTS.
C     REAL FCST(IFCST,NFCSTO)
C        THE STORAGE ARRAY FOR THE FORECASTS.
C     REAL FCSTSD(NFCST)
C        THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS.
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PARAR(MBO)
C        THE AUTOREGRESSIVE PARAMETERS
C     REAL PARDF(NPARDF)
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS.
C     REAL PARMA(MBO)
C        THE MOVING AVERAGE PARAMETERS
C     REAL PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     REAL PV(N1:N2)
C        THE PREDICTED VALUE OF THE FIT.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL 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     REAL T(2*MBO)
C        A TEMPORARY WORK VECTOR.
C     REAL TEMP(MBO)
C        A TEMPORARY WORK VECTOR
C     REAL T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     REAL WSUM
C        THE SUM OF THE WEIGHTS SQUARED, USED TO COMPUTE THE
C        STANDARD DEVIATION OF THE FORECAST.
C     REAL WSUMT
C        A TEMPORARY STORAGE LOCATION FOR WSUM.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
      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 = SDOT(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.0E0
      IF (PMU.NE.0.0E0) THEN
        IF (NPARAR.GE.1) THEN
          DO 20 J = 1, NPARAR
            CONST = CONST - PARAR(J)
   20     CONTINUE
        END IF
        CONST = (1.0E0 + 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.0E0
        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.0E0
      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.975E0, 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
        IF (NPRT.NE.0)
     +    CALL AMFOUT(F, FSD, N, NFCST, IFCSTO, IFO, NFCSTO, Y, T975,
     +    PAGE)
C
  100 CONTINUE
C
      RETURN
C
      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
      REAL
     +   T975
      INTEGER
     +   IFO,N,NFCST,NFCSTO
      LOGICAL
     +   PAGE
C
C  ARRAY ARGUMENTS
      REAL
     +   F(*),FSD(*),Y(*)
      INTEGER
     +   IFCSTO(*)
C
C  LOCAL SCALARS
      REAL
     +   FL,FU,SCALE,YMN,YMX
      INTEGER
     +   I,IEND,IF,ILIM,INTER,IPF,IPFL,IPFU,IPRT,IPY,IY,J
C
C  LOCAL ARRAYS
      REAL
     +   YLIM(4)
      CHARACTER
     +   LINE(53)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMFHDR,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT,MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL F(NFCST)
C        THE FORECASTS.
C     REAL FL
C        THE LOWER 95 PERCENT CONFIDENCE LIMIT FOR THE FORECAST
C     REAL FSD(NFCST)
C        THE STANDARD DEVIATIONS OF THE FORECASTS.
C     REAL 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     REAL SCALE
C        THE PLOT SCALE.
C     REAL T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C     REAL YLIM(4)
C        THE VALUES OF THE AXIS LABELS.
C     REAL YMN
C        THE MINIMUM VALUE TO BE PLOTTED.
C     REAL YMX
C        THE MAXIMUM VALUE TO BE PLOTTED.
C
C     SET VARIABLES FOR PLOTS
C
      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.0E0
   30 CONTINUE
C
      CALL AMFHDR(PAGE, .TRUE., 0)
      WRITE (IPRT, 1030) IFO
      WRITE (IPRT, 1000) YMN, YLIM(2), YLIM(4),
     +  YLIM(1), YLIM(4), YMX
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.5E0)
           LINE(IPY) = '*'
           WRITE (IPRT, 1020) I, (LINE(J),J=1,IEND), I, Y(I)
         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.5E0)
             IPFU = INT(((FU-YMN) / SCALE) + 1.5E0)
             DO 60 J = IPFL, IPFU
               LINE(J) = '-'
   60        CONTINUE
             LINE(IPFL) = '('
             LINE(IPFU) = ')'
             IPY = INT(((Y(I)-YMN) / SCALE) + 1.5E0)
             LINE(IPY) = '*'
             IPF = INT(((F(IF)-YMN) / SCALE) + 1.5E0)
             IF (IPF.NE.IPY) THEN
               LINE(IPF) = 'X'
             ELSE
               LINE(IPF) = '2'
             END IF
             WRITE (IPRT, 1010) I, (LINE(J),J=1,IEND), I,
     +         F(IF), FL, FU, Y(I)
           ELSE
             IPFL = INT(((FL-YMN) / SCALE) + 1.5E0)
             IPFU = INT(((FU-YMN) / SCALE) + 1.5E0)
             DO 70 J = IPFL, IPFU
               LINE(J) = '-'
   70        CONTINUE
             LINE(IPFL) = '('
             LINE(IPFU) = ')'
             IPF = INT(((F(IF)-YMN) / SCALE) + 1.5E0)
             LINE(IPF) = 'X'
             WRITE (IPRT, 1010) I, (LINE(J),J=1,IEND), I,
     +         F(IF), FL, FU
           END IF
         END IF
   80 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//
     +  82X, ' --------------------95  PERCENT'/
     +  1X, 3(G15.8, 5X), 21X,
     +  ' --------------CONFIDENCE LIMITS',
     +  ' ---------ACTUAL'/
     +  11X, 2(G15.8, 5X), G15.8,
     +  ' ------FORECASTS ----------LOWER',
     +  ' ----------UPPER -------IF KNOWN'/
     +  9X, 5('I---------'), 'I', 6X,
     +  ' ------------[X] ------------[(]',
     +  ' ------------[)] ------------[*]')
 1010 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 4(1X, G15.8))
 1020 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 49X, G15.8)
 1030 FORMAT (//' FORECASTS FOR ORIGIN ', I2)
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
      REAL
     +   T975
      INTEGER
     +   IAMHD,IPARMN,IPARMX,LBLTYP,LSCALE,LSTPT,LVCVL,NFAC,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),SCALE(*),STPT(*),VCVL(*)
      INTEGER
     +   IFIXD(*),MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      REAL
     +   FPLM,PLL,PUL,RATIO,SDPAR
      INTEGER
     +   IPRT,J,K,L,LL,LPAR,ORDER
C
C  LOCAL ARRAYS
      CHARACTER
     +   FIXED(3)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FIXPRT,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER*1 FIXED(3)
C        THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT.
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PLL
C        THE LOWER CONFIDENCE LIMIT FOR A GIVEN PARAMETER.
C     REAL PUL
C        THE UPPER CONFIDENCE LIMIT FOR A GIVEN PARAMETER.
C     REAL RATIO
C        THE RATIO OF A GIVEN PARAMETER VALUE TO ITS STANDARD ERROR.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPAR
C        THE STANDARD DEVIATION OF A GIVEN PARAMETER VALUE.
C     REAL STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     REAL T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     REAL VCVL(LVCVL)
C        THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED
C        ROW WISE.
C
C
      FPLM = R1MACH(2)
C
      CALL IPRINT(IPRT)
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 ((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) GO TO 25
          CALL FIXPRT(IFIXD(L), FIXED)
          IF (LBLTYP.EQ.1) WRITE(IPRT, 1000) L, J, ORDER,
     +      (FIXED(K),K=1,3), PAR(L)
          IF (LBLTYP.EQ.2) WRITE(IPRT, 1004) L,
     +      (FIXED(K),K=1,3), PAR(L)
          IF (LBLTYP.EQ.3) WRITE(IPRT, 1005) L, J, ORDER,
     +      (FIXED(K),K=1,3), PAR(L)
            IF (IAMHD.EQ.3) GO TO 10
C
            IF (IFIXD(L).EQ.0) GO TO 5
            WRITE (IPRT, 1007)
            GO TO 10
C
    5       CONTINUE
            IF (SCALE(1).LE.0.0E0) WRITE (IPRT, 1001) STPT(L)
            IF (SCALE(1).GT.0.0E0) WRITE (IPRT, 1002) SCALE(L), STPT(L)
   10     CONTINUE
          IF (IAMHD .EQ. 1) GO TO 30
C
          IF (IFIXD(L).EQ.0) GO TO 20
          WRITE(IPRT, 1006)
          GO TO 30
C
   20     CONTINUE
          LPAR = LPAR + 1
          RATIO = FPLM
          LL = LPAR*(LPAR-1)/2 + LPAR
          IF (VCVL(LL).GT.0.0E0) RATIO = PAR(L)/SQRT(VCVL(LL))
          SDPAR = SQRT(VCVL(LL))
          PLL = PAR(L) - T975*SDPAR
          PUL = PAR(L) + T975*SDPAR
          WRITE(IPRT, 1003) SDPAR, RATIO, PLL, PUL
          GO TO 30
   25     CONTINUE
          IF (LBLTYP.EQ.1) WRITE(IPRT, 1010) L, J, ORDER, PAR(L)
          IF (LBLTYP.EQ.2) WRITE(IPRT, 1014) L, PAR(L)
          IF (LBLTYP.EQ.3) WRITE(IPRT, 1015) L, J, ORDER, PAR(L)
   30   CONTINUE
        IPARMN = IPARMX + 1
   40 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(1X, I5, 2X, 'AR (FACTOR', I2, ')',4X,I5,6X,3A1,E17.8)
 1001 FORMAT ('+', 65X, 7HDEFAULT, E17.8)
 1002 FORMAT ('+', 55X, 2E17.8)
 1003 FORMAT ('+', 55X, 4(2X, E15.8))
 1004 FORMAT(1X, I5, 13X, 'MU', 4X, '  ---' ,6X,3A1,E17.8)
 1005 FORMAT(1X, I5, 2X, 'MA (FACTOR', I2, ')',4X,I5,6X,3A1,E17.8)
 1006 FORMAT('+', 55X, 4(14X, '---'))
 1007 FORMAT('+', 69X, '---', 14X, '---')
 1010 FORMAT(1X, I5, 2X, 'AR (FACTOR', I2, ')',4X,I5,E17.8)
 1014 FORMAT(1X, I5, 13X, 'MU', 4X, '  ---' ,E17.8)
 1015 FORMAT(1X, I5, 2X, 'MA (FACTOR', I2, ')',4X,I5,E17.8)
      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
      REAL
     +   RSD,RSS
      INTEGER
     +   IAMHD,IDF,LSCALE,LSTPT,LVCVL,N,NFAC,NPAR,NPARDF,NPARE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),SCALE(*),STPT(*),VCVL(*)
      INTEGER
     +   IFIXD(*),MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      REAL
     +   FPLM,T975
      INTEGER
     +   IPARMN,IPARMX,IPRT,LBLTYP
C
C  EXTERNAL FUNCTIONS
      REAL
     +   PPFT,R1MACH
      EXTERNAL PPFT,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMLST1,IPRINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     REAL T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     REAL VCVL(LVCVL)
C        THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED
C        ROW WISE.
C
      FPLM = R1MACH(2)
C
      CALL IPRINT(IPRT)
C
C     PRINT HEADING FOR INFORMATION ABOUT PARAMETERS
C
      WRITE(IPRT, 1001)
C
      IF (IAMHD .EQ. 1) WRITE(IPRT, 1004)
      IF (IAMHD .EQ. 2) WRITE(IPRT, 1005)
      IF (IAMHD .EQ. 3) WRITE(IPRT, 1006)
      WRITE(IPRT, 1001)
C
C     PRINT MODEL SUMMARY INFORMATION
C
      IPARMN = 1
      IPARMX = 0
      T975 = PPFT(0.95E0, 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 (IPRT, 1160) N
      IF (IAMHD.GE.2)
     +   WRITE (IPRT, 1040) RSS, RSD, N, NPARDF, NPARE, IDF
      RETURN
C
C     FORMAT STATEMENTS
C
 1001 FORMAT(1X)
 1004 FORMAT (//73X, '  --STEP SIZE FOR'/
     +  39X, '  ------PARAMETER', 17X, '  --APPROXIMATING'/
     +  ' -----------------PARAMETER DESCRIPTION  STARTING VALUES',
     +  '  ----------SCALE  -----DERIVATIVE'/
     +  ' INDEX  ---------TYPE  --ORDER  --FIXED  ----------(PAR)',
     +  '  --------(SCALE)  ----------(STP)')
 1005 FORMAT(30X, '  ------PARAMETER'/
     +  ' --------PARAMETER DESCRIPTION  ------ESTIMATES'/
     +  ' INDEX  ---------TYPE  --ORDER  ----------(PAR)')
 1006 FORMAT(
     +  39X, '  ------PARAMETER  -----STD DEV OF', 17X,
     +  '  ---------------------APPROXIMATE'/
     +  ' -----------------PARAMETER DESCRIPTION  ------ESTIMATES',
     +  '  ------PARAMETER  ----------RATIO',
     +  '  ----95 PERCENT CONFIDENCE LIMITS'/
     +  ' INDEX  ---------TYPE  --ORDER  --FIXED  ----------(PAR)',
     +  '  ------ESTIMATES',
     +  '  PAR/(SD OF PAR)  ----------LOWER  ----------UPPER')
 1040 FORMAT (//' RESIDUAL SUM OF SQUARES       ', 8X, G15.7,
     +  '  (BACKFORECASTS INCLUDED)'//6H RESID,
     +   25HUAL STANDARD DEVIATION   , 8X, G15.7/19H BASED ON DEGREES O,
     +   9HF FREEDOM, 1X, I4, 3H - , I3, 3H - , I3, 3H = , I4)
 1160 FORMAT (//23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5)
      END
*AOS
      SUBROUTINE AOS (N, LAGMAX, ACOV, PRHO, IAR, OSPVAR, PHI, WORK,
     +   AIC, FTEST, LACOV, LAIC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES AUTOREGRESSIVE MODEL ORDER SELECTION
C     STATISTICS. IT PERFORMS STEPWISE FITTING OF AUTOREGRESSIVE
C     COEFFICIENTS BY DURBINS METHOD USING AKAIKES AIC CRITERION
C     FOR SELECTING ORDER.   THE ROUTINE IS MODELED AFTER
C     SUBROUTINE UFPE WRITTEN BY DICK JONES.
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
      REAL
     +   OSPVAR
      INTEGER
     +   IAR,LACOV,LAGMAX,LAIC,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(LACOV),AIC(LAIC),FTEST(2,LAGMAX),PHI(LAGMAX),
     +   PRHO(LAGMAX),WORK(LAGMAX)
C
C  LOCAL SCALARS
      REAL
     +   ACOV0,AICMIN,FPLM,RSS,RSSMIN,SQPACF
      INTEGER
     +   I,J
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFF,R1MACH
      EXTERNAL CDFF,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ARCOEF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG,REAL
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV), ACOV0
C        THE AUTOCOVARIANCES FOR LAGS ZERO TO LAGMAX, AND THE
C        AUTOCOVARIANCE AT LAG ZERO.
C     REAL AIC(LAIC), AICMIN
C        THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER, WHERE
C        AIC(I+1) IS THE CRITERIA FOR ORDER I-1, AND THE MINIMUM
C        CRITERIA COMPUTED.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL FTEST(2, LAGMAX)
C        THE ARRAY IN WHICH THE F PERCENTAGE POINT AND PROBABILITY ARE
C        STORED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR).
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL PRHO(LAGMAX)
C        THE ARRAY CONTAINING THE PARTIAL AUTOCORRELATION
C        COEFFICIENTS.
C     REAL RSS, RSSMIN
C        THE ONE STEP PREDICTION RESIDUAL SUM OF SQUARES AND THE
C        MINIMUM ONE STEP PREDICTION RESIDUAL SUM OF SQUARES.
C     REAL SQPACF
C        THE SQUARED VALUE OF THE PARTIAL AUTOCORRELATION FUNCTION AT
C        LAG I.
C     REAL WORK(LAGMAX)
C        A REAL WORK AREA.
C
      FPLM = R1MACH(2)
C
      RSS = ACOV(1) * N
      RSSMIN = RSS
      AIC(1) = N * LOG(RSS * (N+1) / (N-1))
      AICMIN = AIC(1)
      IAR = 0
C
C  START STEPWISE PROCEDURE
C
      WORK(1) = ACOV(2) / ACOV(1)
      PRHO(1) = WORK(1)
      RSS = RSS * (1.0E0 - WORK(1)*WORK(1))
      AIC(2) = N * LOG(RSS * (N+2) / (N-2))
C
      SQPACF = WORK(1) * WORK(1)
      FTEST(1, 1) = FPLM
      FTEST(2, 1) = 0.0E0
      IF (SQPACF .GE. 1.0E0) GO TO 5
C
      FTEST(1,1) = (N-2) * SQPACF / (1.0E0 - SQPACF)
C
      FTEST(2,1) = 1.0E0 - CDFF(FTEST(1,1), 1.0E0, REAL(N-2))
C
    5 CONTINUE
C
      IF (AIC(2).GE.AICMIN) GO TO 10
      AICMIN = AIC(2)
      RSSMIN = RSS
      IAR = 1
      PHI(1) = WORK(1)
C
   10 IF (LAGMAX.LE.1) GO TO 40
C
      ACOV0 = ACOV(1)
C
      DO 30 I=2,LAGMAX
         CALL ARCOEF (ACOV(2), WORK, RSS, I, LAGMAX, ACOV0)
         PRHO(I) = WORK(I)
         AIC(I+1) = FPLM
         FTEST(1,I) = FPLM
         FTEST(2,I) = FPLM
         IF (I.EQ.N-1) GO TO 15
C
         AIC(I+1) = N * LOG(RSS * (N+I+1) / (N-I-1))
C
         SQPACF = WORK(I) * WORK(I)
         IF (SQPACF .GE. 1.0E0) GO TO 15
C
         FTEST(1,I) = (N-I-1) * SQPACF / (1.0E0 - SQPACF)
C
         FTEST(2,I) = 1.0E0 - CDFF(FTEST(1,I), 1.0E0, REAL(N-I-1))
C
   15    CONTINUE
C
C     IF THIS AIC IS A MINIMUM AND ITS LAG DOES NOT EXCEED N/2,
C     SAVE THE COEFFICIENTS.
C
         IF ((AIC(I+1).GE.AICMIN) .OR. (I.GT.N/2)) GO TO 30
         AICMIN = AIC(I+1)
         RSSMIN = RSS
         IAR = I
         DO 20 J=1,I
            PHI(J) = WORK(J)
   20    CONTINUE
   30 CONTINUE
C
C   NORMALIZE AIC
C
   40 CONTINUE
      AIC(1) = AIC(1) - AICMIN
      DO 50 I=1,LAGMAX
         AIC(I+1) = AIC(I+1) - AICMIN
   50 CONTINUE
C
      OSPVAR = RSSMIN / (N-IAR-1)
C
      RETURN
      END
*AOSLST
      SUBROUTINE AOSLST (PRHO, AIC, FTEST, LAGMAX, LAIC, IAR, PHI,
     +   OSPVAR, IFPRHO, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE LISTS THE AUTOREGRESSIVE MODEL ORDER SELECTION
C     STATISTICS.
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
      REAL
     +   OSPVAR
      INTEGER
     +   IAR,LAGMAX,LAIC,N
      LOGICAL
     +   IFPRHO
C
C  ARRAY ARGUMENTS
      REAL
     +   AIC(*),FTEST(2,*),PHI(*),PRHO(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IMAX,IMIN,IPRT,LAG,M,NPERL
      CHARACTER
     +   FMT*160
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AIC(LAIC)
C        THE ARRAY CONTAINING THE AKAIKES INFORMATION CRITERION.
C     CHARACTER*160 FMT
C        THE FORMAT USED.
C     REAL FTEST(2, LAGMAX)
C        THE ARRAY CONTIANING THE PARTIAL F RATIO AND ITS PROBABILITY
C        OF BEING EXCEEDED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE MODEL SELECTED.
C     LOGICAL IFPRHO
C        THE LOGICAL VARIABLE USED TO INDICATE IF THE PARTIAL
C        AUTOCORRELATIONS ARE BEING PRINTED.  IF -IFPRHO- IS
C        .FALSE. THE AUTOCORRELATIONA AND THEIR STANDARD ERRORS
C        ARE PRINTED,  IF .TRUE., THE PARTIALS.
C     INTEGER IMAX, IMIN
C        THE INDEX VALUES OF THE FIRST AND LAST OBSERVATION
C        TO BE PRINTED PER LINE
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT
C     INTEGER LAG
C        THE LAG VALUE OF THE AUTOREGRESSIVE ORDER SELECTION STATISTIC
C        BEING PRINTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG AT WHICH THE AUTOREGRESSIVE ORDER SELECTION
C        STATISTICS WERE COMPUTED.
C     INTEGER LAIC
C        THE LENGTH OF THE VECTOR AIC.
C     INTEGER M
C        AN INDEX VARIABLE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NPERL
C        THE NUMBER OF VALUES TO BE PRINTED PER LINE.
C     REAL OSPVAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED.
C     REAL PHI(LAGMAX)
C        THE AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED ORDER.
C     REAL PRHO(LAGMAX)
C        THE ARRAY CONTAINING THE PARTIAL AUTOCORRELATION
C        COEFFICIENTS.
C
      CALL IPRINT(IPRT)
C
      NPERL = 12
      DO 30 I = 1, LAGMAX, NPERL
         IMIN = I
         IMAX = MIN(I + NPERL - 1, LAGMAX)
         WRITE(IPRT, 1000) (LAG, LAG = IMIN, IMAX)
         IF (IFPRHO) WRITE (IPRT, 1001) (PRHO(LAG), LAG = IMIN, IMAX)
C
         IF ((IMAX.EQ.LAGMAX) .AND. (LAGMAX.EQ.(N-1))) THEN
            IF (IMAX-IMIN.GE.1) THEN
               WRITE(FMT, 1002) IMAX-IMIN
            ELSE
               WRITE(FMT, 1003)
            END IF
            WRITE(IPRT, FMT) ' AIC               ',
     +                       (AIC(LAG+1), LAG = IMIN, IMAX-1)
            WRITE(IPRT, FMT) ' F RATIO           ',
     +                       (FTEST(1, LAG), LAG = IMIN, IMAX-1)
            WRITE(IPRT, FMT) ' F PROBABILITY     ',
     +                       (FTEST(2, LAG), LAG = IMIN, IMAX-1)
         ELSE
            WRITE(FMT, 1004) NPERL
            WRITE(IPRT, FMT) ' AIC               ',
     +                       (AIC(LAG+1), LAG = IMIN, IMAX)
            WRITE(IPRT, FMT) ' F RATIO           ',
     +                       (FTEST(1, LAG), LAG = IMIN, IMAX)
            WRITE(IPRT, FMT) ' F PROBABILITY     ',
     +                       (FTEST(2, LAG), LAG = IMIN, IMAX)
         END IF
   30 CONTINUE
C
      IF (LAGMAX.EQ.N-1) WRITE(IPRT, 1009)
C
C     PRINT INFORMATION ON ORDER SELECTED
C
      WRITE (IPRT, 1005) IAR, OSPVAR
C
      IF (IAR .EQ. 0) RETURN
C
      WRITE(IPRT, 1008)
C
      DO 40 I = 1, IAR, NPERL
         IMIN = I
         IMAX = MIN(I + NPERL - 1, IAR)
         WRITE (IPRT, 1006) (M, M = IMIN, IMAX)
         WRITE (IPRT, 1007) (PHI(M), M = IMIN, IMAX)
   40 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/19H LAG               , 12(1X, I6))
 1001 FORMAT( 19H PACF              , 12(2X, F5.2))
 1002 FORMAT('(A19,',I2,'(1X, F6.2), 7H ******)')
 1003 FORMAT('(A19, 7H ******)')
 1004 FORMAT('(A19,',I2,'(1X, F6.2))')
 1005 FORMAT (//
     +   49H ORDER AUTOREGRESSIVE PROCESS SELECTED =         , I6/
     +   51H ONE STEP PREDICTION VARIANCE OF PROCESS SELECTED =, G15.8/)
 1006 FORMAT (/19H COEFFICIENT NUMBER, 12(1X, I6))
 1007 FORMAT ( 19H COEFFICIENT VALUE , 12(1X, F6.4))
 1008 FORMAT (45H YULE-WALKER ESTIMATES OF THE COEFFICIENTS OF,
     +   36H THE AUTOREGRESSIVE PROCESS SELECTED)
 1009 FORMAT (/'****** THIS VALUE CANNOT BE COMPUTED',
     +         ' BECAUSE LAG = N-1'//)
C
      END
*AOV1ER
      SUBROUTINE AOV1ER(Y, TAG, N, IGSTAT, NZTAGS, NG, LDSTAK, NMSUB,
     +   INDEX, ISAOV1, NALL0)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE DOES PRELIMINARY CHECKING FOR ERRORS IN THE INPUT
C     PARAMETERS OF THE ONEWAY FAMILY.
C
C     WRITTEN BY -
C        LINDA L. MITCHELL AND JANET R. DONALDSON
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IGSTAT,INDEX,ISAOV1,LDSTAK,N,NALL0,NG,NZTAGS
C
C  ARRAY ARGUMENTS
      REAL
     +   TAG(*),Y(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,J,LDSMIN,NV
      LOGICAL
     +   ERROR,HEAD
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   LIGSTA(8)*1,LLDS(8)*1,LN(8)*1,LNG(8)*1,LTAG(8)*1,
     +   LTWO(8)*1,LZERO(8)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,ERVGT,GENI,IPRINT,LDSCMP,SRTIRR,SRTRRI,
     +   STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERROR
C        SET TRUE IF THE ERROR CHECKING ROUTINE FOUND ANY ERRORS
C     LOGICAL HEAD
C        INDICATES WHETHER HEADING NEEDS TO BE PRINTED
C        TRUE - YES, NEEDS TO BE PRINTED
C        FALSE - NO, HAS BEEN PRINTED
C     INTEGER I
C        *
C     INTEGER IERR
C        IF IERR .NE. 0, THEN ERRORS WHERE FOUND IN THE PARAMETERS
C     INTEGER IGSTAT
C        *
C     INTEGER INDEX
C        THE STARTING LOCATION IN THE STACH AREA OF THE INDEX FOR
C        THE SORTED TAGS.
C     INTEGER IPRT
C        THE OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISAOV1
C        AN INDICATOR VARIABLE USED FOR THE COMPUTATION OF WORK
C        SPACE.  IF ISAOV1 = 0, THE CALLING ROUTINE IS AOV1S.  IF
C        ISAOV1 = 1, THE CALLING ROUTINE IS AOV1.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER J
C        *
C     INTEGER LDSMIN
C        THE MINIMUM SIZE ALLOWED FOR THE STACK
C     INTEGER LDSTAK
C        SIZE OF STACK ALLOCATED IN THE USERS MAIN PROGRAM
C     CHARACTER*1 LIGSTA(8), LLDS(8), LN(8), LNG(8), LTAG(8),
C    *   LTWO(8), LZERO(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE VARIABLE(S) CHECKED
C        ERRORS
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS
C     INTEGER NALL0
C        OUTPUT PARAMETER.  NUMBER OF STACK ALLOCATIONS AFTER
C        STACK IS INITIALIZED.
C     INTEGER NG
C        *
C     CHARACTER*1 NMSUB(6)
C        NAME OF THE CALLING SUBROUTINE
C     INTEGER NV
C        THE NUMBER OF VALUES LESS THAN OR EQUAL TO ZERO.
C     INTEGER NZTAGS
C        THE NUMBER OF POSITIVE NON-ZERO TAGS, TO BE DETERMINED BY
C        THIS ROUTINE
C     REAL TAG(N)
C        THE VECTOR OF TAGS.
C     REAL Y(N)
C        THE VECTOR OF OBSERVATIONS.
C
      DATA  LIGSTA(1),LIGSTA(2),LIGSTA(3),LIGSTA(4),LIGSTA(5),LIGSTA(6),
     +      LIGSTA(7),LIGSTA(8)
     +     / 'I', 'G', 'S', 'T', 'A', '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     LN(1),    LN(2),    LN(3),    LN(4),    LN(5),    LN(6),
     +         LN(7),    LN(8)
     +     / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA    LNG(1),   LNG(2),   LNG(3),   LNG(4),   LNG(5),   LNG(6),
     +        LNG(7),   LNG(8)
     +     / 'N', 'G', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA   LTAG(1),  LTAG(2),  LTAG(3),  LTAG(4),  LTAG(5),  LTAG(6),
     +       LTAG(7),  LTAG(8)
     +     / 'T', 'A', 'G', ' ', ' ', ' ', ' ', ' '/
      DATA   LTWO(1),  LTWO(2),  LTWO(3),  LTWO(4),  LTWO(5),  LTWO(6),
     +       LTWO(7),  LTWO(8)
     +     / 'T', 'W', 'O', ' ', ' ', ' ', ' ', ' '/
      DATA  LZERO(1), LZERO(2), LZERO(3), LZERO(4), LZERO(5), LZERO(6),
     +      LZERO(7), LZERO(8)
     +     / 'Z', 'E', 'R', 'O', ' ', ' ', ' ', ' '/
C
C     COMMENCE BODY OF ROUTINE
C
      IERR = 0
      HEAD = .TRUE.
C
C     SET UP OUTPUT UNIT
      CALL IPRINT(IPRT)
C
C     BEGIN ERROR CHECKING.
C
C     NUMBER OF OBSERVATIONS LESS THAN 2
C
      CALL EISGE(NMSUB, LN, N, 2, 2, HEAD, ERROR, LTWO)
      IF (ERROR) GO TO 50
C
C     NUMBER OF NON-ZERO TAGS LESS THAN 2
C
      CALL ERVGT(NMSUB, LTAG, TAG, N, 0.0E0, (N-2), HEAD, 7, NV, ERROR,
     +   LZERO)
      IF (ERROR) GO TO 50
C
      NZTAGS = N - NV
C
C     STACK MUST BE LARGE ENOUGH FOR A VECTOR OF LENGTH N TO CONTINUE
C
      CALL LDSCMP(1, 0, N, 0, 0, 0, 'S', 0, LDSMIN)
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR, LLDS)
      IF (ERROR) WRITE(IPRT, 1000)
      IF (ERROR) GO TO 50
C
C     INITIALIZE STACK AND NALL0
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      INDEX = STKGET(N,2)
C
C     SORT TAG VECTOR CARRYING ALONG INDEX TO ORIGINAL ORDER AND THE
C     VECTOR OF OBSERVATIONS
C
      CALL GENI(ISTAK(INDEX), N, 1, 1)
      CALL SRTIRR(ISTAK(INDEX), Y, N, TAG)
C
C     COUNT THE NUMBER OF DIFFERENT TAG VALUES
C
      J = N - NZTAGS + 2
      NG = 1
      DO 10 I=J,N
         IF (TAG(I).GT.TAG(I-1)) NG = NG + 1
   10 CONTINUE
C
C     LESS THAN 2 DIFFERENT TAG GROUPS
C
      CALL EISII(NMSUB, LNG, NG, 2, NZTAGS-1, 3, HEAD, ERROR,
     +  LTWO, LN)
      IF (ERROR) GO TO 40
C
C     CHECK THAT DIMENSION OF STATISTICS MATRIX IS SUFFICIENT
C
      CALL EISGE(NMSUB, LIGSTA, IGSTAT, NG, 3, HEAD, ERROR, LNG)
      IF (ERROR) GO TO 40
C
C     COMPUTE AND CHECK FOR SUFFICIENT STACK
C
      CALL LDSCMP(11, 0, N+NZTAGS, 0, 0, 0,
     +            'S', ISAOV1*4*NG+4*NG+NZTAGS, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR, LLDS)
      IF (.NOT.ERROR) RETURN
C
   40 CONTINUE
C
C     REORDER DATA
C
      CALL SRTRRI(TAG, Y, N, ISTAK(INDEX))
C
C     CLEAR STACK, IN CASE WHERE ERROR FOLLOWS ALLOCATION OF STACK.
C
      CALL STKCLR (NALL0)
C
   50 CONTINUE
      IERR = 1
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/' NOTE.  THE VALUE OF LDSTAK MENTIONED ABOVE IS THE',
     +  ' MINIMUM NECESSARY'/
     +  ' TO CONTINUE CHECKING FOR ERRORS AND',
     +  ' TO CALCULATE THE CORRECT VALUE'/
     +  ' OF LDSTAK.  THE CORRECT',
     +  ' VALUE WILL BE LARGER.  CONSULT THE DOCUMENTATION'/
     +  ' FOR THE FORMULAS USED TO CALCULATE LDSTAK.')
      END
*AOV1
      SUBROUTINE AOV1(Y, TAG, N, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE -
C     1. CALLS OTHER ROUTINES TO CHECK THE INPUT PARAMETERS
C     2. SETS UP THE NEEDED STORAGE LOCATIONS, AND
C     3. CALLS AOV1MN TO COMPUTE A COMPREHENSIVE SET OF RESULTS FOR A
C     ONEWAY ANALYSIS OF VARIANCE WITH AUTOMATIC PRINTOUT.
C
C     WRITTEN BY -
C       LINDA MITCHELL
C       STATISTICAL ENGINEERING DIVISION
C       NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C                       BASED ON EARLIER VERSION BY J. R. DONALDSON
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,N
C
C  ARRAY ARGUMENTS
      REAL
     +   TAG(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   B10,DTMEAN,DTSD,DTSIZE,GPMAX,GPMIN,IFP,INDEX,INT,IPRT,
     +   ITEMP,NALL0,NG,NPRT,NZTAGS,RANKS,SRANK,TVAL
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET
      EXTERNAL STKGET
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AOV1ER,AOV1HD,AOV1MN,IPRINT,STKCLR
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER B10
C        STARTING LOCATION IN THE STACK AREA FOR B10
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER DTMEAN
C        THE STARTING LOCATION IN THE STACK AREA FOR THE MEANS
C        OF EACH GROUP
C     INTEGER DTSD
C        THE STARTING LOCATION IN THE STACK AREA OF THE
C        STANDARD DEVIATIONS
C     INTEGER DTSIZE
C        THE STARTING LOCATION IN THE STACK AREA OF THE SIZE OF THE
C        DIFFERENT GROUPS
C     INTEGER GPMAX
C        THE STARTING LOCATION IN THE STACK AREA OF MAXIMUM
C        OBSERVATION
C     INTEGER GPMIN
C        THE STARTING LOCATION IN THE STACK AREA OF THE MINUMUM
C        OBSERVATION
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG INDICATING WHETHER THERE
C        ARE ANY ERRORS, IF = 0 THEN NO ERRORS
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INDEX
C        THE STARTING LOCATION IN THE STACK ARRAY OF THE INDEX FOR
C        THE SORTED TAGS
C     INTEGER INT
C        FRAMEWORK CODE VALUE FOR INTEGER NUMBERS
C     INTEGER IPRT
C        THE OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ITEMP
C        STARTING LOCATION IN THE STACK FOR THE
C        TEMPORARY STORAGE ARRAY
C     INTEGER LDSTAK
C        SIZE OF THE STACK AREA ALLOCATED IN THE USERS MAIN PROGRAM
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS TO BE ANALYZED
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT THIS
C        ROUTINE WAS CALLED.
C     INTEGER NG
C        THE NUMBER OF GROUPS WITH DIFFERENT POSITIVE TAG VALUES
C     CHARACTER*1 NMSUB(6)
C        SUBROUTINE NAME
C     INTEGER NPRT
C        THE VARIABLE CONTROLLING AUTOMATIC PRINTOUT
C        IF =0, PRINTOUT IS SUPRESSED
C        OTHERWISE PRINTOUT IS PROVIDED
C     INTEGER NZTAGS
C        THE NUMBER OF OBSERVATIONS WITH POSITIVE NON-ZERO WIEGHTS
C     INTEGER RANKS
C        THE STARTING LOCATION IN WORK AREA FOR THE RANKS OF Y
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SRANK
C        THE STARTING LOCATION IN STACK FOR THE SUM OF RANKS
C     REAL TAG(N)
C        THE VECTOR OF TAG VALUES
C     INTEGER TVAL
C        THE STARTING LOCATION IN THE STACK FOR THE VECTOR OF
C        THE DIFFERENT POSITIVE TAG VALUES, FOR AOV1
C     REAL Y(N)
C        THE VECTOR OF OBSERVATIONS
C
      DATA   NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +     /      'A',      'O',      'V',      '1',      ' ',      ' '/
C
      CALL IPRINT(IPRT)
C
C     SET UP FRAMEWORK VARIABLES FOR NUMBER TYPES
C
      INT = 2
      IFP = 3
C
C     CHECK FOR ERRORS IN PARAMETERS, INITIALIZE STACK, AND SET NALL0.
C
      CALL AOV1ER(Y, TAG, N, N, NZTAGS, NG, LDSTAK, NMSUB, INDEX, 1,
     +   NALL0)
C
      IF (IERR.EQ.0) GO TO 20
C
C     PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER
C
      IERR = 1
      WRITE (IPRT,1000)
      RETURN
C
C     PRINT HEADING
C
   20 CALL AOV1HD(IPRT)
C
C     SET UP ADDITIONAL WORK VECTORS FOR AOV1MN AS CALLED FROM AOV1
C
      TVAL = STKGET(NG,IFP)
      DTSIZE = STKGET(NG,IFP)
      DTMEAN = STKGET(NG,IFP)
      DTSD = STKGET(NG,IFP)
      SRANK = STKGET(NG,IFP)
      GPMIN = STKGET(NG,IFP)
      GPMAX = STKGET(NG,IFP)
      B10 = STKGET(NG,IFP)
      RANKS = STKGET(NZTAGS,IFP)
      ITEMP = STKGET(NZTAGS,INT)
C
      NPRT = 1
C
      CALL AOV1MN(Y, TAG, N, RSTAK(TVAL), RSTAK(DTSIZE), RSTAK(DTMEAN),
     +   RSTAK(DTSD), NPRT, ISTAK(INDEX), RSTAK(SRANK), RSTAK(GPMIN),
     +   RSTAK(GPMAX), RSTAK(B10), RSTAK(RANKS),
     +   ISTAK(ITEMP), NG, NZTAGS)
C
C     RELEASE THE STACK AREA
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENT
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL AOV1 (Y, TAG, N, LDSTAK)')
      END
*AOV1HD
      SUBROUTINE AOV1HD(IPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A SUBROUTINE TO PRINT OUT THE HEADING FOR THE ONEWAY ANOVA
C     FAMILY, AND IS THE ONLY SOURCE FOR HEADINGS IN THAT FAMILY
C
C     AUTHOR -
C        JOHN E. KOONTZ
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL VERSP
C
C  VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE OUTPUT LOGICAL UNIT NUMBER
C
      CALL VERSP(.TRUE.)
      WRITE (IPRT,1000)
      RETURN
 1000 FORMAT(///48X, 20HANALYSIS OF VARIANCE//)
      END
*AOV1MN
      SUBROUTINE AOV1MN(Y, TAG, N, TVALUE, TSIZE, TMEAN, TSD, NPRT,
     +   INDEX, SRANK, GPMIN, GPMAX, B10, RANKS, ITEMP, NG, NZW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES A COMPREHENSIVE SET OF RESULTS FOR
C     ANALYSIS OF A ONE-WAY CLASSIFICATION WITH OPTIONAL PRINTED OUTPUT.
C     TAG VALUES CAN BE ANY VALUE WHERE ALL MEASUREMENTS WITH TAG
C     VALUES LESS THAN OR EQUAL TO ZERO ARE EXCLUDED FROM ANALYSIS.
C
C     ORIGINALLY WRITTEN FOR OMNITAB BY -
C       DAVID HOGBEN, STATISTICAL ENGINEERING DIVISION, NBS (10/25/69)
C
C     ADAPTED  BY -
C       JANET R. DONALDSON
C       STATISTICAL ENGINEERING DIVISION
C       NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NG,NPRT,NZW
C
C  ARRAY ARGUMENTS
      REAL
     +   B10(*),GPMAX(*),GPMIN(*),RANKS(*),SRANK(*),TAG(*),TMEAN(*),
     +   TSD(*),TSIZE(*),TVALUE(*),Y(*)
      INTEGER
     +   INDEX(*),ITEMP(*)
C
C  LOCAL SCALARS
      REAL
     +   AF,BF,BFRAT,BFSIG,BMS,BSS,C,CC,CFKW,DF,DFRAT,DFSIG,DMS,DSS,F,
     +   F1KW,F2KW,FMLC,FMUC,FNZW,FPLM,FSTAT,G1,GM,GR,HSTAT,IBAR,K0,
     +   MF,MKW,Q,RESSQ,RMLC,RMUC,RX,SBMS,SC,SFRAT,SFSIG,SIGKW,SLBF,
     +   SLCC,SMAX,SMIN,SMS,SNC,SOS,SQB,SQMS,SQOM,SQT,SSF,SSS,STMS,
     +   SUM,SWMS,T1,T2,T3,TIES,TMS,TSS,U1,U2,UMLC,UMUC,V1,V2,VKW,VLS,
     +   WMS,WSS,YBMAX,YBMIN,YMAX,YMIN
      INTEGER
     +   I,IPRT,ISZ,J,K,KK,KKK,L,M,M28,M3,M5,NN,NNE1,NZPNTR
      CHARACTER
     +   BLANK*1,HIGH*1,ISD*1,LOW*1,MEAN*1
C
C  LOCAL ARRAYS
      REAL
     +   STATS(15)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFF,PPFF,PPFT,R1MACH
      EXTERNAL CDFF,PPFF,PPFT,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GENI,IPRINT,RANKO,SRTIR,SRTRI,SRTRRI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,ANINT,INT,LOG,MAX,MIN,NINT,REAL,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AF
C        A FOR F
C     REAL BF
C        BARTLETT F
C     REAL BFRAT
C        BETWEEN GROUPS F RATIO
C     REAL BFSIG
C        BETWEEN GROUPS SIGNIFICANCE LEVEL
C     CHARACTER*1 BLANK
C        HOLLERITH BLANK
C     REAL BMS
C        BETWEEN MS
C     REAL BSS
C        BETWEEN SS
C     REAL B10(NG)
C        *
C     REAL C
C        INTERMEDIATE RESULT STORAGE
C     REAL CC
C        COCHRANS C
C     REAL CFKW
C        CORRECTION FACTOR FOR KRUSKAL-WALLIS
C     REAL DF
C        D.F.
C     REAL DFRAT
C        DEVIATIONS ABOUT LINE F RATIO
C     REAL DFSIG
C        DEVIATIONS ABOUT LINE F SIGNIFICANCE LEVEL
C     REAL DMS
C        DEVIATIONS ABOUT LINE MS
C     REAL DSS
C        DEVIATIONS ABOUT LINE SS
C     REAL F
C        BETWEEN MEANS F-TEST
C     REAL FMLC
C        FIXED MODEL LOWER CONFIDENCE LIMIT FOR MEAN
C     REAL FMUC
C        FIXED MODEL UPPER CONFIDENCE LIMIT FOR MEAN
C     REAL FNZW
C        *
C     REAL FPLM
C        LARGEST SINGLE PRECISION MAGNITUDE OF MACHINE
C     REAL FSTAT
C        F STATISTIC ASSOCIATED WITH KRUSKAL-WALLIS H STATISTIC
C     REAL F1KW
C        F1 D.F. FOR KRUSKAL-WALLIS F
C     REAL F2KW
C        F2 D.F. FOR KRUSKAL-WALLIS F
C     REAL GM
C        GRAND MEAN, MEAN OF ALL OBSERVATIONS WITH POSITIVE
C        NON-ZERO TAGS
C     REAL GPMAX(NG)
C        THE VECTOR OF MAXIMUM OBSERVATIONS FOR EACH GROUP
C     REAL GPMIN(NG)
C        THE VECTOR OF MINIMUM OBSERVATIONS FOR EACH GROUP
C     REAL GR
C        NZW-NG
C     REAL G1
C        NG-1
C     CHARACTER*1 HIGH
C        HOLLERITH + (PLUS)
C     REAL HSTAT
C        KRUSKAL-WALLIS H STATISTIC, SEE BROWNLEE(1965), PAGE 256
C     INTEGER I
C        INDEX VARIABLE
C     REAL IBAR
C        I BAR, ((SUM OF I)/NZW), WHERE I=1,NZW
C     INTEGER INDEX(N)
C        PERMUTATION VECTOR FOR Y AND LATER FOR TMEAN
C     INTEGER IPRT
C        THE OUTPUT LOGICAL UNIT NUMBER
C     CHARACTER*1 ISD
C        CAN CONTAIN FOLLOWING CHARACTERS FOR PRINTING
C        +, -,  (BLANK)
C     INTEGER ISZ
C        INTEGER SIZE OF GROUP
C     INTEGER ITEMP(NZW)
C        TEMPORARY INDEX VECTOR USED IN COMPUTING RANKS
C     INTEGER J
C        AN INDEX VARIABLE
C     INTEGER K
C        INDEX VARIABLE
C     INTEGER KK
C        POINTER TO THE LARGEST OF THE GROUP MEANS
C     INTEGER KKK
C        POINTER TO THE SMALLEST OF THE GROUP MEANS
C     REAL K0
C        = NZW - (SNC/NZW)/ G1
C     INTEGER L
C        INDEX VARIABLE
C     CHARACTER*1 LOW
C        HOLLERITH - (MINUS)
C     INTEGER M
C        INDEX VARIABLE
C     CHARACTER*1 MEAN
C        CAN CONTAIN FOLLOWING CHARACTERS FOR PRINTING
C        +, -,  (BLANK)
C     REAL MF
C        M FOR F
C     REAL MKW
C        M FOR KRUSKAL-WALLIS MEAN
C     INTEGER M28
C        USED IN CREATING BACKWARD LOOP
C     INTEGER M3
C        NG - 2
C     INTEGER M5
C        NZW - 1
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS
C     INTEGER NG
C        THE NUMBER OF GROUPS OF DIFFERENT POSITIVE TAG VALUES
C     INTEGER NN
C        AID IN PRINTING VALUES
C     INTEGER NNE1
C        NUMBER OF GROUPS WITH SIZE NOT EQUAL TO ONE
C     INTEGER NPRT
C        THE VARAIBLE CONTROLLING AUTOMATIC PRINTOUT
C        IF NPRT = 0, PRINTOUT SUPPRESSED
C           OTHERWISE PRINTOUT PROVIDED
C     INTEGER NZPNTR
C        A POINTER TO THE FIRST NON-ZERO TAG IN THE SORTED TAG VECTOR
C     INTEGER NZW
C        THE NUMBER OF OBSERVATIONS WITH POSITIVE, NON-ZERO, TAG VALUES
C     REAL Q
C        SIGNIFICANCE LEVEL FROM F-DISTRIBUTION
C     REAL RANKS(NZW)
C        THE RANKS OF THE OBSERVATIONS WITH POSITIVE TAG VALUES
C     REAL RESSQ
C        RESIDUALS SQUARED
C     REAL RMLC
C        RANDOM MODEL LOWER CONFIDENCE LIMIT FOR MEAN
C     REAL RMUC
C        RANDOM MODEL UPPER CONFIDENCE LIMIT FOR MEAN
C     REAL RX
C        USED IN CALCULATING MANDEL APPROXIMATION
C     REAL SBMS
C        SQRT BETWEEN MS
C     REAL SC
C        SUM OF N(I) CUBED, WHERE N(I) IS THE SIZE OF GROUP I
C     REAL SFRAT
C        SLOPE F RATIO
C     REAL SFSIG
C        SLOPE F SIGNIFICANCE LEVEL
C     REAL SIGKW
C        SIGNIFICANCE LEVEL FOR KRUSKAL-WALLIS F (OR H)
C     REAL SLBF
C        SIGNIFICANCE LEVEL FOR BARLETT F
C     REAL SLCC
C        SIGNIFICANCE LEVEL FOR COCHRANS C
C     REAL SMAX
C        MAXIMUM OF S(I), WHERE S(I) IS THE STD. DEV. OF GROUP I
C     REAL SMIN
C        MINIMUM OF S(I)
C     REAL SMS
C        SLOPE MS
C     REAL SNC
C        SUM OF N(I) SQUARED
C     REAL SOS
C        SUM OF S(I) SQUARED
C     REAL SQB
C        SQRT BETWEEN MS / NZW
C     REAL SQMS
C        SQRT WITHIN MS / NZW
C     REAL SQOM
C        OMEGA HAT SQUARED
C     REAL SQT
C        SQRT TOTAL MS / NZW
C     REAL SRANK(NG)
C        THE SUM OF THE RANKS FOR THE OBSERVATIONS IN EACH GROUP
C     REAL SSF
C        S * SQRT(NG-1) * F
C     REAL SSS
C        SLOPE SS
C     REAL STATS(15)
C        VECTOR OF STATISTICS
C     REAL STMS
C        SQRT TOTAL MS
C     REAL SUM
C        INTERMIDIATE VALUE
C     REAL SWMS
C        SQRT WITHIN MS
C     REAL TAG(N)
C        VECTOR OF CLASSIFICATION VALUES - VALUES LESS THAN OR EQUAL
C        TO ZERO ARE IGNORED FOR ANALYSIS.  ON ENTERING TAG IS
C        SORTED SMALLEST TO LARGEST
C     REAL TIES
C        *
C     REAL TMEAN(NG)
C        THE MEAN OF EACH OF THE GROUPS
C     REAL TMS
C        TOTAL MS
C     REAL TSD(NG)
C        THE STANDARD DEVIATIONS OF EACH OF THE GROUPS (NOT THE
C        STANDARD DEVIATIONS OF THE MEANS)
C     REAL TSIZE(NG)
C        THE SIZE OF EACH OF THE DIFFERENT GROUPS
C     REAL TSS
C        TOTAL SS
C     REAL TVALUE(NG)
C        THE DIFFERENT POSITIVE (NON-ZERO) TAG VALUES ANALYZED, ORDERED
C        FROM SMALLEST TO LARGEST
C     REAL T1
C        T(.05,NG-1)
C     REAL T2
C        T(.05,NG-1)
C     REAL T3
C        T(.05,NZW-1)
C     REAL UMLC
C        UNGROUPED MODEL LOWER CONFIDENCE LIMIT FOR MEAN
C     REAL UMUC
C        UNGROUPED MODEL UPPER CONFIDENCE LIMIT FOR MEAN
C     REAL U1, U2
C        USED IN CALCULATING MANDEL APPROXIMATION
C     REAL VKW
C        U FOR KRUSKAL-WALLIS F
C     REAL VLS
C        LARGEST VARIANCE / SMALLEST VARIANCE
C     REAL V1, V2
C        USED IN CALCULATING MANDEL APPROXIMATION
C     REAL WMS
C        WITHIN MS
C     REAL WSS
C        WITHIN SS
C     REAL Y(N)
C        OBSERVATIONS TO BE ANALYZED, SORTED BY TAGS
C        Y(NZPNTR) IS THE FIRST ELEMENT WITH A NON-ZERO TAG
C     REAL YBMAX
C        MAXIMUM YBAR(I), WHERE YBAR(I) IS THE MEAN OF GROUP I
C     REAL YBMIN
C        MINIMUN YBAR(I)
C     REAL YMAX
C        MAXIMUM OBSERVATION
C     REAL YMIN
C        MINIMUM OBSERVATION
C
C     MACHINE DEPENDENT VARIABLE - FPLM
C
      DATA BLANK /' '/
      DATA LOW /'-'/
      DATA HIGH /'+'/
C
      CALL IPRINT(IPRT)
      FPLM = R1MACH(2)
      NZPNTR = N - NZW + 1
      FNZW = NZW
C
C     ZERO WORK VECTORS
C
      DO 10 I=1,NG
         TVALUE(I) = 0.0E0
         TSIZE(I) = 0.0E0
         TMEAN(I) = 0.0E0
         TSD(I) = 0.0E0
         SRANK(I) = 0.0E0
         GPMIN(I) = 0.0E0
         GPMAX(I) = 0.0E0
         B10(I) = 0.0E0
   10 CONTINUE
C
      DO 20 I=1,15
         STATS(I) = 0.0E0
   20 CONTINUE
C
      CC = 0.0E0
      F = 0.0E0
      DMS = 0.0E0
      BSS = 0.0E0
      WSS = 0.0E0
      HSTAT = 0.0E0
      MF = 0.0E0
      SC = 0.0E0
      SMAX = 0.0E0
      NNE1 = 0
      SNC = 0.0E0
      SOS = 0.0E0
      SSS = 0.0E0
      SUM = 0.0E0
      TIES = 0.0E0
      TSS = 0.0E0
      SMIN = 0.0E0
      SFRAT = 0.0E0
C
C     BEGIN COMPUTATIONS
C
C     COMPUTE RANKS
C
      CALL RANKO(NZW, Y(NZPNTR), ITEMP, RANKS, TIES)
C
C     INITIALIZE FIRST ELEMENT BEFORE ENTERING LOOP
C
      TVALUE(1) = TAG(NZPNTR)
      SRANK(1) = RANKS(1)
      GPMIN(1) = Y(NZPNTR)
      GPMAX(1) = Y(NZPNTR)
      YMIN = GPMIN(1)
      YMAX = GPMAX(1)
      GM = Y(NZPNTR)
      IBAR = 1.0E0
      TMEAN(1) = Y(NZPNTR)
      TSIZE(1) = 1.0E0
C
C     DETERMINE MEANS AND MAXS, DO SUMMATION PRIOR TO
C     DETERIMING MEANS
C     HERE J IS THE GROUP NUMBER
C
      J = 1
      L = NZPNTR + 1
      DO 50 I=L,N
         IF (TAG(I).EQ.TAG(I-1)) GO TO 40
C
C        NEW TAG GROUP
         J = J + 1
         TVALUE(J) = TAG(I)
         GPMIN(J) = Y(I)
         GPMAX(J) = Y(I)
   40    TSIZE(J) = TSIZE(J) + 1.0E0
         TMEAN(J) = TMEAN(J) + Y(I)
         GM = GM + Y(I)
C
C     UNNECESSARY COMPUTATIONS IF PRINTED OUTPUT IS SUPRESSED
C
         IF (NPRT.EQ.0) GO TO 50
         K = I + 1 - NZPNTR
         SRANK(J) = SRANK(J) + RANKS(K)
         GPMIN(J) = MIN(GPMIN(J),Y(I))
         GPMAX(J) = MAX(GPMAX(J),Y(I))
         YMIN = MIN(YMIN,GPMIN(J))
         YMAX = MAX(YMAX,GPMAX(J))
         IBAR = IBAR + J
   50 CONTINUE
C
C     CALCULATE MEANS
C
      GM = GM/FNZW
      IBAR = IBAR/FNZW
      K = NZPNTR-1
      I = NZPNTR
      DO 70 J=1,NG
         IF (TSIZE(J).GE.2.0E0) THEN
            TMEAN(J) = TMEAN(J)/TSIZE(J)
         ELSE
            TMEAN(J) = TMEAN(J)
         END IF
         K = K + INT(TSIZE(J))
C
C     L GIVES INDEX TO Y VALUE WITHIN GROUP J
C
         DO 60 L=I,K
            RESSQ = (Y(L)-TMEAN(J))*(Y(L)-TMEAN(J))
            TSD(J) = TSD(J) + RESSQ
            IF (NPRT.EQ.0) GO TO 60
            BSS = BSS + (TMEAN(J)-GM)*(TMEAN(J)-GM)
            WSS = WSS + RESSQ
            TSS = TSS + (Y(L)-GM)*(Y(L)-GM)
   60    CONTINUE
         I = K + 1
   70 CONTINUE
C
C     NOW DONE WITH TAG VECTOR, RETURN VECTOR TO INPUT ORDER
C     INDEX IS FREED FOR USE IN OTHER PLACES
C
      CALL SRTRRI(TAG, Y, N, INDEX)
C
C     CHECK FOR PRINTED OUTPUT
C
      IF (NPRT.NE.0) GO TO 90
C
C     COMPUTE STANDARD DEVIATIONS WITHIN EACH GROUP
C
      DO 80 J=1,NG
         TSD(J) = SQRT(TSD(J))
         IF (TSIZE(J).LE.1.0E0) GO TO 80
         TSD(J) = TSD(J)/SQRT(TSIZE(J)-1.0E0)
   80 CONTINUE
C
C     COMPUTATIONS COMPLETE FOR STORED OUTPUT - RETURN IF PRINTED
C     OUTPUT IS SUPRESSED
C
      RETURN
   90 YBMIN = TMEAN(1)
      YBMAX = TMEAN(1)
      SMIN = FPLM
C     HERE I IS THE GROUP NUMBER
      DO 120 I=1,NG
         IF (TSD(I).GT.0.0E0) THEN
            B10(I) = TSIZE(I)*(TSIZE(I)-1.0E0)/TSD(I)
            STATS(1) = STATS(1) + B10(I)*TMEAN(I)
            STATS(2) = STATS(2) + B10(I)
            IF (TSIZE(I).GT.1.0E0) THEN
               TSD(I) = SQRT(TSD(I)/(TSIZE(I)-1.0E0))
            END IF
            MF = MF + (TSIZE(I)-1.0E0)*LOG(TSD(I)*TSD(I))
         END IF
         IF (NINT(TSIZE(I)).GE.2) THEN
            NNE1 = NNE1 + 1
            SMAX = MAX(SMAX,TSD(I))
            SMIN = MIN(SMIN,TSD(I))
            STATS(3) = STATS(3) + 1.0E0/(TSIZE(I)-1.0E0)
         END IF
         SSS = SSS + TSIZE(I)*(I-IBAR)*(TMEAN(I)-GM)
         STATS(4) = STATS(4) + TSIZE(I)*(I-IBAR)*(I-IBAR)
C
C        LOOK FOR SMALLEST AND LARGEST MEANS (YBAR)
C
         YBMIN = MIN(YBMIN,TMEAN(I))
         YBMAX = MAX(YBMAX,TMEAN(I))
C
         HSTAT = HSTAT + SRANK(I)*SRANK(I)/TSIZE(I)
         SUM = SUM + 1.0E0/TSIZE(I)
         STATS(5) = STATS(5) + (TMEAN(I)-GM)*(TMEAN(I)-GM)
         SOS = SOS + TSD(I)*TSD(I)
         SNC = SNC + TSIZE(I)*TSIZE(I)
         SC = SC + TSIZE(I)*TSIZE(I)*TSIZE(I)
  120 CONTINUE
      IF (STATS(2).NE.0.0E0) STATS(1) = STATS(1)/STATS(2)
      IF (STATS(4).NE.0.0E0) SSS = SSS*SSS/STATS(4)
      DSS = BSS - SSS
C
C     DEGREES OF FREEDOM FOR ANOVA
C
      G1 = NG-1
      M3 = NG - 2
      GR = NZW-NG
      M5 = NZW - 1
C
C     MEAN SQUARES
C
      BMS = BSS/G1
      SMS = SSS
      IF (NG.GE.3) DMS = DSS/M3
      WMS = WSS/GR
      TMS = TSS/M5
      IF (WMS.EQ.BMS) THEN
         BFRAT = 1.0E0
         BFSIG = 1.0E0
      ELSE IF (WMS.EQ.0.0E0) THEN
         BFRAT = FPLM
         BFSIG = 0.0E0
      ELSE
         BFRAT = BMS/WMS
         BFSIG = 1.0E0 - CDFF(BFRAT,G1,GR)
      END IF
      IF (WMS.EQ.DMS) THEN
         DFRAT = 1.0E0
         DFSIG = 1.0E0
      ELSE IF (WMS.EQ.0.0E0) THEN
         DFRAT = FPLM
         DFSIG = 0.0E0
      ELSE
         DFRAT = DMS/WMS
         DFSIG = 1.0E0 - CDFF(DFRAT,REAL(M3),REAL(NZW-2))
      END IF
      IF (SMS.EQ.DSS+WSS) THEN
         SFRAT = 1.0E0
         SFSIG = 1.0E0
      ELSE IF (DSS+WSS.EQ.0.0E0) THEN
         SFRAT = FPLM
         SFSIG = 0.0E0
      ELSE
         SFRAT = SMS/((DSS+WSS)/(FNZW-2.0E0))
         SFSIG = 1.0E0 - CDFF(SFRAT,1.0E0,GR)
      END IF
C
C     COMPUTE FOR KRUSKAL-WALLIS TEST
C     FOR FORMULAE WITH CLEARER FORM AND NAMES SEE
C     KRAFT AND VAN EEDEN  A NON PARAMETRIC INTRODUCTION TO STATISTICS,
C     PP. 238 - 240
C
      STATS(6) = NZW*(NZW+1)
      HSTAT = (12.0E0*HSTAT/STATS(6)) - (3.0E0*(NZW+1))
      IF (TIES.EQ.NZW*NZW*NZW-NZW) THEN
         CFKW = 0.0E0
         HSTAT = 0.0E0
         MKW = 0.0E0
      ELSE
         CFKW = 1.0E0 - TIES/(NZW*NZW*NZW-NZW)
         HSTAT = HSTAT/CFKW
         MKW = ((NZW*NZW*NZW-SC)/STATS(6))/CFKW
      END IF
      VKW = 2.0E0*G1 -
     +   (0.4E0*(3*NG*M3+NZW*(2*NG*(NG-3)+1)))/STATS(6)
     +   - 6.0E0*SUM/5.0E0
      IF (MKW-HSTAT.GT.0.0E0 .AND.
     +    MKW.NE.0.0E0 .AND. VKW.NE.0.0E0) THEN
         F1KW = (G1*(G1*(MKW-G1)-VKW))/(0.5E0*VKW*MKW)
         F2KW = (MKW-G1)*F1KW/G1
         FSTAT = (HSTAT*(MKW-G1))/(G1*(MKW-HSTAT))
         SIGKW = 1.0E0 - CDFF(FSTAT,ANINT(F1KW),ANINT(F2KW))
      ELSE
         SIGKW = 0.0E0
      END IF
C
C     COMPUTE TOTAL STATISTICS
C
      SWMS = SQRT(WMS)
      SBMS = SQRT(STATS(5)/G1)
      STMS = SQRT(TMS)
      SQMS = SWMS/(SQRT(FNZW))
      SQB = SBMS/(SQRT(REAL(NG)))
      SQT = STMS/(SQRT(FNZW))
      T1 = PPFT(0.975E0,INT(GR))
      T2 = PPFT(0.975E0,INT(G1))
      T3 = PPFT(0.975E0,M5)
      FMLC = GM - SQMS*T1
      RMLC = GM - SQB*T2
      UMLC = GM - SQT*T3
      FMUC = GM + SQMS*T1
      RMUC = GM + SQB*T2
      UMUC = GM + SQT*T3
C
      SSF = SWMS*SQRT(G1*PPFF(0.95E0,INT(G1),INT(GR)))
C
C     TESTS FOR HOMOGENEITY OF VARIANCES
C
      IF (SMAX*SMAX.EQ.SOS) THEN
         CC = 1.0E0
      ELSE IF (SOS.NE.0.0E0) THEN
         CC = SMAX*SMAX/SOS
      END IF
      STATS(7) = ANINT(FNZW/NG)
      IF ((NNE1.GE.2) .AND. (CC.NE.1.0E0)) THEN
         SLCC = 1.0E0 -
     +          CDFF((NNE1-1)*CC/(1.0E0-CC),STATS(7),
     +          STATS(7)*(NNE1-1))
      ELSE
         SLCC = 1.0E0
      END IF
      SLCC = (NNE1-1)*SLCC
      IF (SLCC.GT.1.0E0) SLCC = 1.0E0
C
      IF (SMIN.EQ.SMAX) THEN
         VLS = 1.0E0
      ELSE
         IF (SMIN.EQ.0.0E0) THEN
            VLS = FPLM
         ELSE
            VLS = (SMAX/SMIN)*(SMAX/SMIN)
         END IF
      END IF
      IF (WMS.GT.0.0E0) MF = GR*LOG(WMS) - MF
      AF = (STATS(3)-(1.0E0/GR))/(3.0E0*G1)
      SLBF = 1.0E0
      IF ((AF.NE.1.0E0) .AND. (NNE1.GE.2)) THEN
         DF = (NNE1+1)/(AF*AF)
         BF = (DF*MF)/((NNE1-1)*(DF/(1.0E0-AF+(2.0E0/DF))-MF))
         IF (BF.LT.0.0E0) BF = 0.0E0
         SLBF = 1.0E0 - CDFF(BF,REAL(NNE1-1),ANINT(DF))
      ELSE
         BF = FPLM
      END IF
      K0 = (FNZW-(SNC/FNZW))/G1
      SQOM = (BMS-WMS)/K0
C
C     COMPUTATIONS ARE NOW COMPLETE ************************************
C
C     PRINT ANOVA
C
      NN = N - NZW
      WRITE (IPRT,1000) NN
      NN = NG - 1
      WRITE (IPRT,1010) NN, BSS, BMS, BFRAT, BFSIG
      IF (NG.LT.3) GO TO 180
      IF (BFSIG.GE..10) GO TO 180
      NN = 1
      WRITE (IPRT,1020) NN, SSS, SMS, SFRAT, SFSIG
      WRITE (IPRT,1030) M3, DSS, DMS, DFRAT, DFSIG
  180 NN = NZW - NG
      WRITE (IPRT,1040) NN, WSS, WMS
      WRITE (IPRT,1050) M5, TSS
C
C     PRINT KRUSKAL-WALLIS TEST
C
      WRITE (IPRT,1060) HSTAT, SIGKW
C
C     PRINT ESTIMATES
C
      WRITE (IPRT,1070)
      DO 200 I=1,NG
         MEAN = BLANK
         IF (TMEAN(I).LE.YBMIN) MEAN = LOW
         IF (TMEAN(I).GE.YBMAX) MEAN = HIGH
         ISD = BLANK
         IF (TSD(I).LE.SMIN) ISD = LOW
         IF (TSD(I).GE.SMAX) ISD = HIGH
         ISZ = INT(TSIZE(I))
         IF (ISZ.LE.1) THEN
            WRITE (IPRT,1090) TVALUE(I), ISZ, TMEAN(I), MEAN, GPMIN(I),
     +         GPMAX(I), SRANK(I)
         ELSE
            STATS(9) = TSD(I)/SQRT(TSIZE(I))
            STATS(10) = PPFT(0.975E0,ISZ-1)
            STATS(8) = TMEAN(I) - STATS(9)*STATS(10)
            STATS(11) = TMEAN(I) + STATS(9)*STATS(10)
            WRITE (IPRT,1080) TVALUE(I), ISZ, TMEAN(I), MEAN, TSD(I),
     +                        ISD, STATS(9), GPMIN(I), GPMAX(I),
     +                        SRANK(I), STATS(8), STATS(11)
         END IF
  200 CONTINUE
      WRITE (IPRT,1100) NZW, GM, YMIN, YMAX, SWMS, SQMS, FMLC, FMUC,
     +   SBMS, SQB, RMLC, RMUC, STMS, SQT, UMLC, UMUC
      IF (BFSIG.LT.0.10) THEN
C
C     SORT YBAR FOR MULTIPLE COMPARISIONS OF MEANS
C
         CALL GENI(INDEX, NG, 1, 1)
         CALL SRTIR(INDEX, NG, TMEAN)
C
C     COMPUTE AND PRINT FOR MULTIPLE COMPARISIONS
C
         IF (NZW-NG.LT.4) GO TO 270
         WRITE (IPRT,1110)
C
C     NEWMAN-KEULS-HARTLEY
C
         WRITE (IPRT,1120)
         RX = -.283917E0 + 2.63532E0*(GR-1.00123E0)**(-.95862E0)
         U1 = -.314115E0 + 2.38301E0*(GR-1.03428E0)**(-.864005E0)
         U2 = 3.65961E0*U1**2 - 1.00891E0*U1 - 0.166346E0
         J = 1
         M28 = 0
  210    I = NG
  220    IF (I.LE.M28) GO TO 260
         IF (I.EQ.J) GO TO 230
         STATS(14) = ABS(TMEAN(I)-TMEAN(J))
C
C     MANDEL APPROXMATION TO PERCENT POINT OF STUDENTIZED RANGE
C
         STATS(12) = I-J+1
         C = 2.3849867E0 -
     +       2.9051857E0*(STATS(12)-0.57583164E0)**(-.069648109E0)
         V1 = 1.30153E0 -
     +        1.95073E0*(STATS(12)+.394915E0)**(-.139783E0)
         V2 = 4.72863E0*V1**2 + 0.404271E0*V1 - 0.135104E0
         STATS(13) = 6.15075E0 + 4.441409E0*RX +
     +               6.7514569E0*C + 7.4671282E0*U1*V1 -
     +               0.157537E0*U2*V2
         KK = INDEX(I)
         KKK = INDEX(J)
         STATS(13) = STATS(13)*
     +            SQRT(0.5E0*((1.0E0/TSIZE(KK))+(1.0E0/TSIZE(KKK))))*
     +            SWMS
         IF (STATS(14).LE.STATS(13)) GO TO 230
         I = I - 1
         GO TO 220
  230    IF (J.EQ.1) GO TO 250
         IF (J.GT.M28) GO TO 240
         WRITE (IPRT,1150)
         GO TO 250
  240    WRITE (IPRT,1160)
  250    WRITE (IPRT,1140) (TMEAN(M),M=J,I)
         IF (I.GE.NG) GO TO 270
         M28 = I
  260    J = J + 1
         GO TO 210
C
C     SCHEFFE METHOD
C
  270    WRITE (IPRT,1130)
         J = 1
         M28 = 0
  280    I = NG
  290    IF (I.LE.M28) GO TO 330
         IF (I.EQ.J) GO TO 300
         KK = INDEX(I)
         KKK = INDEX(J)
         STATS(14) = ABS(TMEAN(I)-TMEAN(J))
         STATS(13) = SSF*SQRT((1.0E0/TSIZE(KK))+(1./TSIZE(KKK)))
         IF (STATS(14)-STATS(13).LE.0.0E0) GO TO 300
         I = I - 1
         GO TO 290
  300    IF (J.EQ.1) GO TO 320
         IF (J.GT.M28) GO TO 310
         WRITE (IPRT,1150)
         GO TO 320
  310    WRITE (IPRT,1160)
  320    WRITE (IPRT,1140) (TMEAN(M),M=J,I)
         IF (I.GE.NG) GO TO 340
         M28 = I
  330    J = J + 1
         GO TO 280
C
C     RETURN TAG MEANS TO ORIGINAL ORDER
C
  340    CALL SRTRI(TMEAN, NG, INDEX)
      END IF
C
      IF (NNE1.LE.1) RETURN
      WRITE (IPRT,1170) CC, SLCC, BF, SLBF, VLS
      IF (SLCC.GT.0.1E0 .AND. SLBF.GT.0.1E0) GO TO 390
      DO 360 I=1,NG
         F = F + B10(I)*(TMEAN(I)-STATS(1))*(TMEAN(I)-STATS(1))
         IF (STATS(2).EQ.0.0E0 .OR. TSIZE(I).LE.1.0E0) GO TO 360
         STATS(15) = STATS(15) +
     +               (1.0E0-B10(I)*B10(I)/STATS(2)/STATS(2))/
     +               (TSIZE(I)-1.0E0)
  360 CONTINUE
      IF (STATS(15).EQ.0.0E0) GO TO 370
      STATS(15) = (NG*NG-1.0E0)/(3.0E0*STATS(15))
      IF (NG.LE.1) GO TO 370
      F = (F/G1)/(1.0E0+(2.0E0*M3/(3.0E0*STATS(15))))
      GO TO 380
  370 F = 0.0E0
  380 Q = 1.0E0 - CDFF(F,G1,ANINT(STATS(15)))
      WRITE (IPRT,1180) F, Q
  390 WRITE (IPRT,1190) SQOM
      RETURN
C
C     AUTOMATIC PRINTOUT IS FINISHED
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(54H *GROUP NUMBERS HAVE BEEN ASSIGNED ACCORDING TO TAG VA,
     +   59HLUES GIVEN, WHERE THE SMALLEST TAG GREATER THAN ZERO HAS BE,
     +   14HEN ASSIGNED  */41H *GROUP NUMBER 1, THE NEXT SMALLEST, GROU,
     +   59HP NUMBER 2, ETC.  TAGS LESS THAN OR EQUAL TO ZERO HAVE NOT ,
     +   27HBEEN INCLUDED IN ANALYSIS.*/28H *NUMBER OF VALUES EXCLUDED ,
     +   17HFROM ANALYSIS IS , I4, 77X, 1H*//17X, 6HSOURCE, 14X, 4HD.F.,
     +   4X, 14HSUM OF SQUARES, 5X, 12HMEAN SQUARES, 9X, 7HF RATIO, 4X,
     +   7HF PROB./)
 1010 FORMAT(17X, 14HBETWEEN GROUPS, 5X, I4, 1P2E18.6, 4X, 0PE11.3,
     +   F10.3)
 1020 FORMAT(20X, 5HSLOPE, 14X, I4, 1P2E18.6, 3X, 0PE11.3, F10.3)
 1030 FORMAT(20X, 16HDEVS. ABOUT LINE, 3X, I4, 1P2E18.6, 3X, 0PE11.3,
     +   F10.3)
 1040 FORMAT(17X, 13HWITHIN GROUPS, 6X, I4, 1P2E18.6)
 1050 FORMAT(17X, 5HTOTAL, 14X, I4, 1PE18.6//)
 1060 FORMAT(11X, 49HKRUSKAL-WALLIS RANK TEST FOR DIFFERENCE BETWEEN G,
     +   16HROUP MEANS * H =, E11.3, 10H, F PROB =, F6.3, 10H (APPROX.)
     +   /)
 1070 FORMAT(55X, 9HESTIMATES/96X, 6HSUM OF/5X, 5H TAG , 10X, 3HNO.,
     +   6X, 4HMEAN, 7X, 11HWITHIN S.D., 2X, 12HS.D. OF MEAN, 5X,
     +   7HMINIMUM, 7X, 7HMAXIMUM, 6X, 5HRANKS, 3X, 16H95PCT CONF INT F,
     +   7HOR MEAN/)
 1080 FORMAT(1X, 1PE14.6, I8, E14.5, A1, E13.5, A1, E13.5, 2E14.5,
     +   0PF9.1, 1PE13.5, 3H TO, E12.5)
 1090 FORMAT(1X, 1PE14.6, I8, E14.5, A1, 3X, 23H ESTIMATE NOT AVAILABLE,
     +   ' ', 2E14.5, 0PF9.1, 3X, 25H********** TO ********** )
 1100 FORMAT(/11X, 5HTOTAL, I7, 1PE14.5, 28X, 2E14.5//
     +   17X, 20HFIXED EFFECTS MODEL , 2E14.5, 37X, E13.5, 3H TO, E12.5/
     +   17X, 7HRANDOM ,
     +   13HEFFECTS MODEL, 2E14.5, 37X, E13.5, 3H TO, E12.5/17X,
     +   14HUNGROUPED DATA, 6X, 2E14.5, 37X, E13.5, 3H TO, E12.5/)
 1110 FORMAT(1X, 50HPAIRWISE MULTIPLE COMPARISON OF MEANS.  THE MEANS ,
     +   59HARE PUT IN INCREASING ORDER IN GROUPS SEPARATED BY *****.  ,
     +   11HA MEAN IS  /44H ADJUDGED NON-SIGNIFICANTLY DIFFERENT FROM A,
     +   59HNY MEAN IN THE SAME GROUP AND SIGNIFICANTLY DIFFERENT AT TH,
     +   17HE .05 LEVEL FROM /38H ANY MEAN IN ANOTHER GROUP.  ***** ***,
     +   59H** INDICATES ADJACENT GROUPS HAVE NO COMMON MEAN.          ,
     +   23H                       )
 1120 FORMAT(/3X, 49HNEWMAN-KEULS TECHNIQUE, HARTLEY MODIFICATION. (AP,
     +   40HPROXIMATE IF GROUP NUMBERS ARE UNEQUAL.))
 1130 FORMAT(/3X, 18HSCHEFFE TECHNIQUE.)
 1140 FORMAT(3X, 9(1PE12.5, ','))
 1150 FORMAT(6X, 5H*****)
 1160 FORMAT(3X, 11H***** *****)
 1170 FORMAT(/36H TESTS FOR HOMOGENEITY OF VARIANCES./7X, 9HCOCHRANS ,
     +   35HC = MAX. VARIANCE/SUM(VARIANCES) = , F7.4, 6H, P = , F6.3,
     +   10H (APPROX.)/7X, 17HBARTLETT-BOX F = , F9.3, 6H, P = ,
     +   F6.3/7X, 38HMAXIMUM VARIANCE / MINIMUM VARIANCE = , F14.4)
 1180 FORMAT(7X, 50HAPPROX BETWEEN MEANS F-TEST IN PRESENCE OF HETEROG,
     +   20HENEOUS VARIANCE. F =, F8.3, 5H, P =, F6.3)
 1190 FORMAT(/35H MODEL II - COMPONENTS OF VARIANCE./7X, 10HESTIMATE O,
     +   20HF BETWEEN COMPONENT , 1PE14.6)
      END
*AOV1S
      SUBROUTINE AOV1S(Y, TAG, N, LDSTAK, NPRT, GSTAT, IGSTAT, NG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE -
C     1. CALLS OTHER ROUTINES TO CHECK THE INPUT PARAMETERS
C     2. SETS UP NEEDED STORAGE LOCATIONS AND
C     3. CALLS AOV1MN TO COMPUTE A COMPREHENSIVE SET OF RESULTS FOR A
C         ONEWAY ANALYSIS OF VARIANCE WITH OPTIONAL OUTPUT.
C
C     WRITTEN BY -
C       LINDA MITCHELL
C       STATISTICAL ENGINEERING DIVISION
C       NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C                       BASED ON EARLIER VERSION BY J. R. DONALDSON
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IGSTAT,LDSTAK,N,NG,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   GSTAT(*),TAG(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   B10,GPMAX,GPMIN,IFP,INDEX,INT,IPRT,ITEMP,NALL0,NZTAGS,
     +   RANKS,SRANK
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET
      EXTERNAL STKGET
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AOV1ER,AOV1HD,AOV1MN,IPRINT,STKCLR
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER B10
C        STARTING LOCATION IN THE STACK AREA FOR B10
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER GPMAX
C        THE STARTING LOCATION IN THE STACK AREA OF MAXIMUM
C        OBSERVATION
C     INTEGER GPMIN
C        THE STARTING LOCATION IN THE STACK AREA OF THE MINUMUM
C        OBSERVATION
C     REAL GSTAT(IGSTAT,4)
C        THE GROUP STATISTICS.  COLUMNS CORRESPOND TO THE TAG
C        VALUE, SAMPLE SIZE, GROUP MEAN, AND GROUP STANDARD DEVIATION.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG INDICATING WHETHER THERE
C        ARE ANY ERRORS, IF = 0 THEN NO ERRORS
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IGSTAT
C        THE FIRST DIMENSION OF GSTAT.
C     INTEGER INDEX
C        THE STARTING LOCATION IN THE STACK ARRAY OF THE INDEX FOR
C        THE SORTED TAGS
C     INTEGER INT
C        FRAMEWORK CODE VALUE FOR INTEGER NUMBERS
C     INTEGER IPRT
C        THE OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ITEMP
C        STARTING LOCATION IN THE STACK FOR THE
C        TEMPORARY STORAGE ARRAY
C     INTEGER LDSTAK
C         SIZE OF THE STACK AREA ALLOCATED IN THE USERS MAIN PROGRAM
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS TO BE ANALYZED
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT THIS
C        ROUTINE WAS CALLED.
C     INTEGER NG
C        THE COMPUTED NUMBER OF GROUPS WITH
C        DIFFERENT POSITIVE TAG VALUES
C     CHARACTER*1 NMSUB(6)
C        SUBROUTINE NAME
C     INTEGER NPRT
C        THE VARIABLE CONTROLLING AUTOMATIC PRINTOUT
C        IF =0, PRINTOUT IS SUPRESSED
C        OTHERWISE PRINTOUT IS PROVIDED
C     INTEGER NZTAGS
C        THE NUMBER OF OBSERVATIONS WITH POSITIVE NON-ZERO WIEGHTS
C     INTEGER RANKS
C        THE STARTING LOCATION IN STACK AREA FOR THE RANKS OF Y
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SRANK
C        THE STARTING LOCATION IN STACK FOR THE SUM OF RANKS
C     REAL TAG(N)
C        THE VECTOR OF TAG VALUES
C     REAL Y(N)
C        THE VECTOR OF OBSERVATIONS
C
      DATA   NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +     /      'A',      'O',      'V',      '1',      'S',      ' '/
C
C     SET UP FRAMEWORK VARIABLES FOR NUMBER TYPES
C
      INT = 2
      IFP = 3
C
      CALL IPRINT(IPRT)
C
C     CHECK FOR ERRORS IN PARAMETERS, INITIALIZE STACK, AND SET
C     NALL0.
C
      CALL AOV1ER(Y, TAG, N, IGSTAT, NZTAGS, NG, LDSTAK, NMSUB, INDEX,
     +   0, NALL0)
C
      IF (IERR.EQ.0) GO TO 20
C
C     PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER
C
      IERR = 1
      WRITE (IPRT,1000)
      RETURN
C
C     PRINT HEADING IF DESIRED
C
   20 IF (NPRT.EQ.0) GO TO 30
      CALL AOV1HD(IPRT)
C
C     SET UP ADDITIONAL WORK VECTORS FOR AOV1MN AS CALLED FROM AOV1S
C
   30 SRANK = STKGET(NG,IFP)
      GPMIN = STKGET(NG,IFP)
      GPMAX = STKGET(NG,IFP)
      B10 = STKGET(NG,IFP)
      RANKS = STKGET(NZTAGS,IFP)
      ITEMP = STKGET(NZTAGS,INT)
C
      CALL AOV1MN(Y, TAG, N,
     +            GSTAT(1), GSTAT(IGSTAT+1),
     +            GSTAT(2*IGSTAT+1), GSTAT(3*IGSTAT+1),
     +            NPRT, ISTAK(INDEX), RSTAK(SRANK), RSTAK(GPMIN),
     +            RSTAK(GPMAX), RSTAK(B10), RSTAK(RANKS),
     +            ISTAK(ITEMP), NG, NZTAGS)
C
C     RELEASE THE STACK AREA
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL AOV1S (Y, TAG, N, LDSTAK, NPRT, GSTAT, IGSTAT, NG)')
      END
*AOV1XP
      SUBROUTINE AOV1XP(GSTAT, IGSTAT, NG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     PRINT STORAGE FOR ONEWAY FAMILY EXERCISER
C     AND CLEAR STORAGE VECTORS
C
C     WRITTEN BY -
C        LINDA MITCHELL
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IGSTAT,NG
C
C  ARRAY ARGUMENTS
      REAL
     +   GSTAT(IGSTAT,4)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,J
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,SETRA
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL GSTAT(IGSTAT,4)
C        THE GROUP STATISTICS.  COLUMNS CORRESPOND TO THE TAG
C        VALUE, SAMPLE SIZE, GROUP MEAN, AND GROUP STANDARD DEVIATION.
C     INTEGER I
C        AN INDEX VALUE
C     INTEGER IGSTAT
C        THE FIRST DIMENSION OF GSTAT.
C     INTEGER IPRT
C        THE OUTPUT LOGICAL UNIT NUMBER
C     INTEGER J, NG
C        *
C
C     COMMENCE BODY OF ROUTINE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      WRITE (IPRT,1010) ((GSTAT(I,J),J=1,4),I=1,NG)
      CALL SETRA(GSTAT, IGSTAT, 4, NG, 0.0E0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(//21H STORAGE FROM AOV1   //6X, 8HTAGVALUE,
     +   11X, 10H GROUPSIZE, 11X, 10H GROUPMEAN, 13X, 8H GROUPSD/)
 1010 FORMAT(4(1X, G20.14))
      END
*ARCOEF
      SUBROUTINE ARCOEF (ACOV, PHI, RSS, LAG, LAGMAX, ACOV0)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE USES DURBINS RECURSIVE METHOD TO COMPUTE
C     THE AUTOREGRESSIVE COEFFICIENTS OF AN ORDER LAG PROCESS,
C     GIVEN ON INPUT THE COEFFICIENTS OF AN ORDER (LAG-1) PROCESS.
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
      REAL
     +   ACOV0,RSS
      INTEGER
     +   LAG,LAGMAX
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),PHI(*)
C
C  LOCAL SCALARS
      REAL
     +   SUM1,SUM2,T
      INTEGER
     +   J,L1,L2,LJ
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LAGMAX)
C        THE ARRAY OF ACVF ESTIMATES FOR LAGS ONE TO LAGMAX.
C     REAL ACOV0
C        THE ACVF FOR LAG ZERO.
C     INTEGER J, LAG
C        INDEX VARIABLES.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE USED.
C     INTEGER LJ, L2
C        INDEX VARIABLES.
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR AN AR
C        PROCESS OF ORDER LAG.
C     REAL RSS
C        THE ONE STEP PREDICTION RESIDUAL SUM OF SQUARES.
C     REAL SUM1, SUM2
C        VARIABLES USED IN THE COMPUTATIONS OF THE AUTOREGRESSIVE
C        COEFFICIENTS.
C     REAL T
C        A TEMPORARY STORAGE LOCATION.
C
      L1 = LAG - 1
      SUM1 = 0.0E0
      SUM2 = 0.0E0
      DO 10 J = 1, L1
         LJ = LAG - J
         SUM1 = SUM1 + PHI(J) * ACOV(LJ)
         SUM2 = SUM2 + PHI(J) * ACOV(J)
   10 CONTINUE
      PHI(LAG) = (ACOV(LAG) - SUM1) / (ACOV0 - SUM2)
      L2 = LAG / 2
      DO 20 J = 1, L2
         LJ = LAG - J
         T = PHI(J) - PHI(LAG) * PHI(LJ)
         PHI(LJ) = PHI(LJ) - PHI(LAG) * PHI(J)
         PHI(J) = T
   20 CONTINUE
C
      RSS = RSS * (1.0E0 - PHI(LAG)*PHI(LAG))
C
      RETURN
      END
*ARFLT
      SUBROUTINE ARFLT (Y, N, IAR, PHI, YF, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PERFORMS THE AUTOREGRESSIVE FILTERING
C     OPERATION DEFINED BY PHI, RETURNING THE FILTERED SERIES
C     IN YF.
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
     +   IAR,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   PHI(*),Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   YMEAN
      INTEGER
     +   I,IPRT
      LOGICAL
     +   ERR01,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,EISGE,FLTAR,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01
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 IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
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     CHARACTER*1 LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
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     REAL PHI(IAR)
C        THE VECTOR CONTAINING THE FILTER COEFFICIENTS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C     REAL YMEAN
C        THE MEAN OF THE INPUT SERIES Y.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'A',       'R',       'F',       'L',       'T',       ' '/
      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
C
      IF (.NOT. ERR01) GO TO 10
C
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     COMPUTE ARITHMETIC MEAN
C
      CALL AMEAN(Y, N, YMEAN)
C
      DO 20 I = 1, N
         YF(I) = Y(I) - YMEAN
   20 CONTINUE
C
      CALL FLTAR (YF, N, IAR, PHI, YF, NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   43H       CALL ARFLT (Y, N, IAR, PHI, YF, NYF))
      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
      REAL
     +   D(P),STEP(P),STLSTG(P),V(*),X(P),X0(P)
      INTEGER
     +   IV(*)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   R1MACH,RELDST
      EXTERNAL R1MACH,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     REAL R1MACH, 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     REAL 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
C  ***  DATA INITIALIZATIONS  ***
C
      DATA HALF/0.5E0/, ONE/1.0E0/, TWO/2.0E0/, ZERO/0.0E0/
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.R1MACH(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.R1MACH(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
*AXPBY
      SUBROUTINE AXPBY(N,SA,SX,INCX,SB,SY,INCY,SZ,INCZ)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE IS ADAPTED FROM BLAS SUBROUTINE SAXPY.
C
C     OVERWRITE REAL SZ WITH REAL SA*SX + SB*SY.
C     FOR I = 0 TO N-1, REPLACE  SZ(LZ+I*INCZ) WITH SA*SX(LX+I*INCX) +
C     SY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N,
C     AND LY AND LZ ARE DEFINED IN A SIMILAR WAY USING INCY AND INCZ,
C     RESPECTIVELY.
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
      REAL
     +   SA,SB
      INTEGER
     +   INCX,INCY,INCZ,N
C
C  ARRAY ARGUMENTS
      REAL
     +   SX(*),SY(*),SZ(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IX,IY,IZ,M,MP1,NS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL SX(N), SY(N), SZ(N)
C
      IF(N.LE.0) RETURN
      IF ((INCX .EQ. 1) .AND. (INCY .EQ. 1) .AND. (INCZ .EQ. 1))
     +   GO TO 20
      IF ((INCX .GE. 2) .AND. (INCX .EQ. INCY) .AND. (INCX .EQ. INCZ))
     +   GO TO 60
C
C        CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IZ = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      IF(INCZ.LT.0)IZ = (-N+1)*INCZ + 1
      DO 10 I = 1,N
        SZ(IZ) = SA*SX(IX) + SB*SY(IY)
        IX = IX + INCX
        IY = IY + INCY
        IZ = IZ + INCZ
   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 4.
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SZ(I) = SA*SX(I) + SB*SY(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        SZ(I) = SA*SX(I) + SB*SY(I)
        SZ(I+1) = SA*SX(I+1) + SB*SY(I+1)
        SZ(I+2) = SA*SX(I+2) + SB*SY(I+2)
        SZ(I+3) = SA*SX(I+3) + SB*SY(I+3)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS = N*INCX
      DO 70 I=1,NS,INCX
        SZ(I) = SA*SX(I) + SB*SY(I)
   70 CONTINUE
      RETURN
      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
      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
*BETAI
      REAL FUNCTION BETAI (X, PIN, QIN)
C APRIL 1977 VERSION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C BASED ON BOSTEN AND BATTISTE, REMARK ON ALGORITHM 179, COMM. ACM,
C V 17, P 153, (1974).
C
C X   VALUE TO WHICH FUNCTION IS TO BE INTEGRATED. X MUST BE IN (0,1).
C P   INPUT (1ST) PARAMETER (MUST BE GREATER THAN 0)
C Q   INPUT (2ND) PARAMETER (MUST BE GREATER THAN 0)
C BETAI  INCOMPLETE BETA FUNCTION RATIO, THE PROBABILITY THAT A RANDOM
C        VARIABLE FROM A BETA DISTRIBUTION HAVING PARAMETERS P AND Q
C        WILL BE LESS THAN OR EQUAL TO X.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL PIN,QIN,X
C
C  LOCAL SCALARS
      REAL ALNEPS,ALNSML,C,EPS,FAC1,FAC2,FINSUM,P,P1,PS,Q,SML,TERM,XB,Y
      INTEGER I,IB,N
C
C  EXTERNAL FUNCTIONS
      REAL ALBETA,R1MACH
      EXTERNAL ALBETA,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,AINT,EXP,FLOAT,LOG,MAX,MIN,REAL
C
      DATA             EPS, ALNEPS, SML, ALNSML / 4*0.0 /
C
      IF (EPS.NE.0.) GO TO 10
      EPS = R1MACH(3)
      ALNEPS = LOG(EPS)
      SML = R1MACH(1)
      ALNSML = LOG(SML)
C
 10   IF (X.LT.0. .OR. X.GT.1.0) CALL XERROR (
     1  'BETAI   X IS NOT IN THE RANGE (0,1)', 35, 1, 2)
      IF (PIN.LE.0. .OR. QIN.LE.0.) CALL XERROR (
     1  'BETAI   P AND/OR Q IS LE ZERO', 29, 2, 2)
C
      Y = X
      P = PIN
      Q = QIN
      IF (Q.LE.P .AND. X.LT.0.8) GO TO 20
      IF (X.LT.0.2) GO TO 20
      Y = 1.0 - Y
      P = QIN
      Q = PIN
C
 20   IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80
C
C EVALUATE THE INFINITE SUM FIRST.
C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I)
C
      PS = Q - AINT(Q)
      IF (PS.EQ.0.) PS = 1.0
      XB = P*LOG(Y) -  ALBETA(PS, P) - LOG(P)
      BETAI = 0.0
      IF (XB.GE.ALNSML) THEN
         BETAI = EXP(XB)
         FAC2 = 1.0
         IF (PS.NE.1.0E0) THEN
            FAC1 = 1.0
            N = MAX(ALNEPS/LOG(Y), 4.0E0)
            DO 30 I=1,N
               IF ((I-PS.EQ.0.0E0) .OR. (FAC1.EQ.0.0E0)) THEN
                  FAC1 = 0.0E0
               ELSE
                  IF (LOG(ABS(FAC1)) + LOG(ABS(I-PS)) + LOG(Y) -
     +                LOG(REAL(I)) .LT. ALNSML) THEN
                     FAC1 = 0.0E0
                  ELSE
                     FAC1 = FAC1 * (I-PS)*Y/I
                  END IF
               END IF
               FAC2 = FAC2 + FAC1*P/(P+I)
 30         CONTINUE
         END IF
         BETAI = BETAI*FAC2
      END IF
C
C NOW EVALUATE THE FINITE SUM, MAYBE.
C
      IF (Q.LE.1.0) GO TO 70
C
      XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q)
      IB = MAX (XB/ALNSML, 0.0)
      TERM = EXP (XB - FLOAT(IB)*ALNSML)
      C = 1.0/(1.0-Y)
      P1 = Q*C/(P+Q-1.)
C
      FINSUM = 0.0
      N = Q
      IF (Q.EQ.FLOAT(N)) N = N - 1
      DO 50 I=1,N
        IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
        IF (Q-I+1.0E0 .EQ. 0.0E0) THEN
          TERM = 0.0E0
        ELSE
          IF (LOG(ABS(Q-I+1.0E0)) + LOG(ABS(C)) + LOG(ABS(TERM)) -
     +        LOG(ABS(P+Q-I)) .LT. ALNSML) THEN
            TERM = 0.0E0
          ELSE
            TERM = (Q-I+1.0E0)*C*TERM/(P+Q-I)
          END IF
        END IF
C
        IF (TERM.GT.1.0) IB = IB - 1
        IF (TERM.GT.1.0) TERM = TERM*SML
C
        IF (IB.EQ.0) FINSUM = FINSUM + TERM
 50   CONTINUE
C
 60   BETAI = BETAI + FINSUM
 70   IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
      BETAI = MAX (MIN (BETAI, 1.0), 0.0)
      RETURN
C
 80   BETAI = 0.0
      XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q)
      IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB)
      IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
      RETURN
C
      END
*BFSDRV
      SUBROUTINE BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1,
     +   SPCF2, NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, LAGMX1,
     +   WORK, LWORK, DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT,
     +   WINDOW, ICCOV, JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2,
     +   IPHAS, CODD, CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION,
     +   NFFT, INLPPC, JNLPPC, LY)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLING ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS .
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
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2
      INTEGER
     +   ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,JCCOV,JNLPPC,
     +   LAGMAX,LAGMX1,LDSMIN,LDSTAK,LPCV,LW,LWORK,LY,M,N,NF,NFFT,
     +   NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*),CEVEN(*),CODD(*),CSPC2(*),FREQ(*),PHAS(*),SPCF1(*),
     +   SPCF2(*),W(*),WORK(*),XAXIS(*),Y1(*),Y2(*),YAXIS(*)
      INTEGER
     +   ISYM(*),LAGS(*),NLPPC(*)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL WINDOW
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   BW,DF,FMN,FMX,XPLTMN,XPLTMX,YMEAN1,YMEAN2,YPLTMN,YPLTMX
      INTEGER
     +   I,ILOG,ISPCER,J,K,LAG,LAGLST,NFUSED,NPTS,NWUSED
      LOGICAL
     +   NEWPG,UNIVAR
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   LSTLAG
      EXTERNAL LSTLAG
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVF,ACVFF,ACVFM,BFSER,BFSLAG,BFSMN,CCVF,CCVFF,CCVFM,
     +   DFBW,DFBWM,SETFRQ,UFSEST,UFSOUT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT,MAX,MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C  STATEMENT FUNCTIONS
      INTEGER
     +   I3C,I3N
C
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL BW
C        THE BANDWIDTH.
C     REAL CCOV(ICCOV,JCCOV,M)
C        THE COVARIANCES.
C     REAL CEVEN(LAGMX1)
C        THE SUMS OF THE COVARIANCES FOR EACH LAG.
C     REAL CODD(LAGMX1)
C        THE DIFFERENCES OF THE COVARIANCES FOR EACH LAG.
C     REAL CSPC2(ICSPC2,NW)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL DF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FMN, FMX
C        *
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
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 ILOG
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        ILOG = 0 THE PLOT IS LINEAR/LINEAR, IF
C        ILOG = 1 THE PLOT IS LOG/LINEAR, IF
C     INTEGER ISPCER
C        AN ERROR FLAG USED FOR THE SPECTRUM PLOTS.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER I3C
C        STATEMENT FUNCTION FOR FINDING LOCATIONS WITHIN CCOV.
C     INTEGER I3N
C        STATEMENT FUNCTION FOR FINDING LOCATIONS WITHIN NLPPC.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF CCOV
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF NLPPC
C     INTEGER LAG
C        THE LAG WINDWO TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGLST
C        THE LAST LAG BEFORE MISSING DATA CAUSED AN ACVF
C        TO BE UNABLE TO BE COMPUTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        THE VALUE LAGMAX+1.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     LOGICAL NEWPG
C        THE LOGICAL VARIABLE USED TO DETERMINE IF OUTPUT
C        WILL BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NFUSED
C        THE NUMBER OF FREQUENCIES ACTUALLY USED.
C     INTEGER NLPPC(INLPPC,JNLPPC,M)
C         THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     INTEGER NWUSED
C        THE NUMBER OF DIFFERENT BANDWIDTHS ACTUALLY USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     REAL PHAS(IPHAS,NW)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRUM.
C     REAL SPCF1(NF), SPCF2(NF)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     LOGICAL UNIVAR
C        THE LOGICAL VARIABLE USED TO DETERMINE IF THE OUTPUT
C        IS FOR UNIVARIATE (TRUE) OR BIVARIATE (FALSE) SPECTRA.
C     REAL W(LW)
C        THE VECTOR OF WINDOWS.
C     EXTERNAL WINDOW
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL WORK(LWORK)
C        THE VECTOR OF WORK SPACE.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMEAN1, YMEAN2
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YMISS1, YMISS2
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IN THE SERIES IS MISSING.  IF Y(I) = YMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C     REAL Y1(N), Y2(N)
C         THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C
C
C  STATEMENT FUNCTION DEFINITIONS
C
      I3C(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV
      I3N(I,J,K) = I + (J-1)*INLPPC + (K-1)*JNLPPC*INLPPC
C
      NFUSED = NF
      IF (OPTION(4)) THEN
        FMN = MAX(FMIN, 0.0E0)
        FMX = MIN(FMAX, 0.5E0)
        IF (FMN.GE.FMX) THEN
          FMN = 0.0E0
          FMX = 0.5E0
        END IF
      ELSE
C
C       SET VARIOUS VALUES FOR SHORT FORMS OF CALL STATEMENT
C
        NPRT = -1
        FMN = 0.0E0
        FMX = 0.5E0
        LAGMX1 = LAGMAX + 1
      END IF
C
C     CHECK FOR ERRORS
C
      CALL BFSER(NMSUB, N, LAGMAX, ICCOV, JCCOV, INLPPC, JNLPPC, M,
     +           INDEX1, INDEX2, ICSPC2, IPHAS, NF, NW, LAGS,
     +           LDSTAK, LDSMIN, LY, NFFT, OPTION)
C
      IF (IERR.EQ.1) RETURN
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      ALPHA = 0.95E0
      DELTA = 1.0E0
C
C     COMPUTE COVARIANCES
C
      LAGLST = LAGMAX
      IF (OPTION(1)) THEN
        CALL ACVFF(Y1, N, NFFT, YMEAN1,
     +             CCOV(I3C(1,INDEX1,INDEX1)),
     +             LAGMAX, ICCOV, N, WORK, NFFT)
        CALL ACVFF(Y2, N, NFFT, YMEAN2,
     +             CCOV(I3C(1,INDEX2,INDEX2)),
     +             LAGMAX, ICCOV, N, WORK, NFFT)
        CALL CCVFF(Y1, Y2, N, NFFT, LAGMAX,
     +             CCOV(I3C(1,INDEX1,INDEX2)),
     +             CCOV(I3C(1,INDEX2,INDEX1)), ICCOV, N, WORK, LWORK)
C
      ELSE
        IF (OPTION(3)) THEN
          IF (OPTION(2)) LAGLST = LSTLAG(NLPPC,LAGMAX,INLPPC)
        ELSE
          IF (OPTION(2)) THEN
            CALL ACVFM(Y1, YMISS1, N, YMEAN1,
     +                 CCOV(I3C(1,INDEX1,INDEX1)),
     +                 LAGMAX, LAGLST, NLPPC, ICCOV)
            CALL ACVFM(Y2, YMISS2, N, YMEAN2,
     +                 CCOV(I3C(1,INDEX2,INDEX2)),
     +                 LAGMAX, LAGLST, NLPPC, ICCOV)
            CALL CCVFM(Y1, YMISS1, Y2, YMISS2, N, LAGMAX, YMEAN1,
     +                 YMEAN2, CCOV(I3C(1,INDEX1,INDEX2)),
     +                 CCOV(I3C(1,INDEX2,INDEX1)), ICCOV,
     +                 NLPPC(I3N(1,INDEX1,INDEX2)),
     +                 NLPPC(I3N(1,INDEX2,INDEX1)))
C
          ELSE
            CALL ACVF(Y1, N, YMEAN1, CCOV(I3C(1,INDEX1,INDEX1)), LAGMAX,
     +                ICCOV)
            CALL ACVF(Y2, N, YMEAN2, CCOV(I3C(1,INDEX2,INDEX2)), LAGMAX,
     +                ICCOV)
            CALL CCVF(Y1, Y2, N, LAGMAX, YMEAN1, YMEAN2,
     +                CCOV(I3C(1,INDEX1,INDEX2)),
     +                CCOV(I3C(1,INDEX2,INDEX1)), ICCOV)
          END IF
        END IF
      END IF
C
      IF (LAGLST.LE.0) THEN
C
C     AN ERROR HAS BEEN DETECTED
C
         IERR = 2
         RETURN
      END IF
C
C     COMPUTE THE VECTOR OF LAG WINDOW TRUNCATION POINTS, ORDERED
C     SMALLEST TO LARGEST.
C
      NWUSED = NW
      IF (.NOT.OPTION(4)) CALL BFSLAG(CCOV, LAGLST, LAGS, N, NW, NWUSED,
     +                                ICCOV, JCCOV, INDEX1, INDEX2)
C
C     BEGIN COMPUTING FOURIER SPECTRUM FOR SERIES
C
      UNIVAR = .FALSE.
C
      ILOG = 0
C
      XPLTMN = FMN
      XPLTMX = FMX
C
      YPLTMN = 0.0E0
      YPLTMX = 1.0E0
C
C     SET FREQUENCIES FOR THE SPECTRUM.
C
      CALL SETFRQ(FREQ, NF, 1, FMN, FMX, DELTA)
C
C     COMPUTE AND PLOT SPECTRUM VALUES.
C
      NEWPG = .FALSE.
C
C     COMPUTE THE EVEN AND ODD CCVF ESTIMATES
C
      CEVEN(1) = CCOV(I3C(1,INDEX1,INDEX2))
      CODD(1) = 0.0E0
      DO 30 I=1,LAGLST
         CEVEN(I+1) = 0.5E0*
     +                (CCOV(I3C(I+1,INDEX1,INDEX2))+
     +                 CCOV(I3C(I+1,INDEX2,INDEX1)))
         CODD(I+1) = 0.5E0*
     +               (CCOV(I3C(I+1,INDEX1,INDEX2))-
     +                CCOV(I3C(I+1,INDEX2,INDEX1)))
   30 CONTINUE
C
      DO 60 I=1,NWUSED
         LAG = LAGS(I)
         IF (LAG.GT.LAGLST) THEN
            ISPCER = 2
            DF = 0.0E0
         ELSE
C
            ISPCER = 0
C
C     COMPUTE THE WINDOW, AND EFFECTIVE DEGREES OF FREEDOM AND
C     BANDWIDTH BASED ON THE WINDOW
C
            CALL WINDOW(LAG, W, LW)
            IF (OPTION(2)) THEN
               CALL DFBWM(N, LAG, W, LW, NLPPC(I3N(1,INDEX1,INDEX2)),
     +                    NLPPC(I3N(1,INDEX2,INDEX1)), INLPPC, DF, BW)
            ELSE
               CALL DFBW(N, LAG, W, LW, DF, BW)
            END IF
C
C     COMPUTE THE SPECTRUM FOR EACH INDIVIDUAL SERIES
C
            CALL UFSEST(CCOV(I3C(1,INDEX1,INDEX1)), W, LAG, SPCF1,
     +                  NFUSED, ICCOV, LAGMAX, NF, FREQ, DELTA)
C
            CALL UFSEST(CCOV(I3C(1,INDEX2,INDEX2)), W, LAG, SPCF2,
     +                  NFUSED, ICCOV, LAGMAX, NF, FREQ, DELTA)
C
            CALL BFSMN(SPCF1, SPCF2, CEVEN, CODD, W, LW, LAG, DF, NPRT,
     +                 NF, CSPC2(1+(I-1)*ICSPC2), PHAS(1+(I-1)*IPHAS),
     +                 FREQ, NPTS, XAXIS,
     +                 YAXIS, ISYM, LPCV, ALPHA, LAGMX1, DELTA)
C
            IF (NPRT.EQ.0) GO TO 60
C
         END IF
         CALL UFSOUT(XAXIS, YAXIS, ISYM, NPTS, BW, INT(DF+0.5E0), LAG,
     +               LAGMAX, NEWPG, ISPCER, NFUSED+5, XPLTMN, XPLTMX,
     +               YPLTMN, YPLTMX, ILOG, PHAS(1+(I-1)*IPHAS), FREQ,
     +               NF, UNIVAR, NMSUB)
C
         NEWPG = .TRUE.
C
   60 CONTINUE
C
      RETURN
C
      END
*BFSER
      SUBROUTINE BFSER(NMSUB, N, LAGMAX, ICCOV, JCCOV, INLPPC, JNLPPC,
     +   M, INDEX1, INDEX2, ICSPC2, IPHAS, NF, NW, LAGS,
     +   LDSTAK, LDSMIN, LYFFT, NFFT, OPTION)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR THE TIME SERIES
C     FOURIER UNIVARIATE SPECTRUM ANALYSIS 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
     +   ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,JCCOV,JNLPPC,
     +   LAGMAX,LDSMIN,LDSTAK,LYFFT,M,N,NF,NFFT,NW
C
C  ARRAY ARGUMENTS
      INTEGER
     +   LAGS(*)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,NV
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERROR(30)
      CHARACTER
     +   L1(8)*1,LICCOV(8)*1,LICSPC(8)*1,LINDX1(8)*1,LINDX2(8)*1,
     +   LINLPP(8)*1,LIPHAS(8)*1,LJCCOV(8)*1,LJNLPP(8)*1,
     +   LLAGMX(8)*1,LLAGS(8)*1,LLDS(8)*1,LLGMX1(8)*1,
     +   LLYFFT(8)*1,LM(8)*1,LN(8)*1,LNF(8)*1,LNM1(8)*1,LNW(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,EISLE,EIVII
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR(30)
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 VALUE.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER JCCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER JNLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     CHARACTER*1 LICCOV(8), LICSPC(8), LINDX1(8),
C    *   LINDX2(8), LINLPP(8), LIPHAS(8), LJCCOV(8), LJNLPP(8),
C    *   LLAGMX(8), LLAGS(8), LLDS(8), LLGMX1(8), LLYFFT(8), LM(8),
C    *   LN(8), LNF(8), LNM1(8), LNW(8), L1(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE ARGUMENT(S)
C        CHECKED FOR ERRORS.
C     INTEGER LYFFT
C        THE LENGTH OF VECTOR YFFT.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THE USER CALLED SUBROUTINE.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND WHEN CHECKING VECTOR LAGS.
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C
C     SET UP NAME ARRAYS
C
      DATA LICCOV(1), LICCOV(2), LICCOV(3), LICCOV(4), LICCOV(5),
     +   LICCOV(6), LICCOV(7), LICCOV(8) /'I','C','C','O','V',' ',' ',
     +   ' '/
      DATA LICSPC(1), LICSPC(2), LICSPC(3), LICSPC(4), LICSPC(5),
     +   LICSPC(6), LICSPC(7), LICSPC(8) /'I','C','S','P','C','2',' ',
     +   ' '/
      DATA LINDX1(1), LINDX1(2), LINDX1(3), LINDX1(4), LINDX1(5),
     +   LINDX1(6), LINDX1(7), LINDX1(8) /'I','N','D','E','X','1',' ',
     +   ' '/
      DATA LINDX2(1), LINDX2(2), LINDX2(3), LINDX2(4), LINDX2(5),
     +   LINDX2(6), LINDX2(7), LINDX2(8) /'I','N','D','E','X','2',' ',
     +   ' '/
      DATA LIPHAS(1), LIPHAS(2), LIPHAS(3), LIPHAS(4), LIPHAS(5),
     +   LIPHAS(6), LIPHAS(7), LIPHAS(8) /'I','P','H','A','S',' ',' ',
     +   ' '/
      DATA LINLPP(1), LINLPP(2), LINLPP(3), LINLPP(4), LINLPP(5),
     +   LINLPP(6), LINLPP(7), LINLPP(8) /'I','N','L','P','P','C',' ',
     +   ' '/
      DATA LJCCOV(1), LJCCOV(2), LJCCOV(3), LJCCOV(4), LJCCOV(5),
     +   LJCCOV(6), LJCCOV(7), LJCCOV(8) /'J','C','C','O','V',' ',' ',
     +   ' '/
      DATA LJNLPP(1), LJNLPP(2), LJNLPP(3), LJNLPP(4), LJNLPP(5),
     +   LJNLPP(6), LJNLPP(7), LJNLPP(8) /'J','N','L','P','P','C',' ',
     +   ' '/
      DATA LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5),
     +   LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ',
     +   ' '/
      DATA LLAGS(1), LLAGS(2), LLAGS(3), LLAGS(4), LLAGS(5), LLAGS(6),
     +   LLAGS(7), LLAGS(8) /'L','A','G','S',' ',' ',' ',' '/
      DATA LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5),
     +   LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+',
     +   '1'/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7),
     +   LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/
      DATA LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6),
     +   LNM1(7), LNM1(8) /'N','-','1',' ',' ',' ',' ',' '/
      DATA LNW(1), LNW(2), LNW(3), LNW(4), LNW(5), LNW(6), LNW(7),
     +   LNW(8) /'N','W',' ',' ',' ',' ',' ',' '/
      DATA LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     +   LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ',
     +   ' '/
      DATA L1(1), L1(2), L1(3), L1(4), L1(5), L1(6), L1(7), L1(8) /'1',
     +   ' ',' ',' ',' ',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
      DO 10 I=1,30
         ERROR(I) = .FALSE.
   10 CONTINUE
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERROR(1), LN)
C
      IF ((.NOT.OPTION(3))) GO TO 20
C
      CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERROR(2), L1,
     +   LNM1)
C
      CALL EISGE(NMSUB, LM, M, 2, 1, HEAD, ERROR(3), LM)
C
      CALL EISGE(NMSUB, LICCOV, ICCOV, LAGMAX+1, 3, HEAD, ERROR(4),
     +   LLGMX1)
C
      CALL EISGE(NMSUB, LJCCOV, JCCOV, M, 4, HEAD, ERROR(5), LM)
C
      IF (OPTION(2)) THEN
        CALL EISGE(NMSUB, LINLPP, INLPPC, LAGMAX+1, 3, HEAD, ERROR(6),
     +     LLGMX1)
C
        CALL EISGE(NMSUB, LJNLPP, JNLPPC, M, 4, HEAD, ERROR(7), LM)
      END IF
C
      CALL EISLE(NMSUB, LINDX1, INDEX1, M, 2, HEAD, ERROR(8), LM)
C
      CALL EISLE(NMSUB, LINDX2, INDEX2, M, 2, HEAD, ERROR(9), LM)
C
   20 CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERROR(10), LLYFFT)
C
      IF (OPTION(1) .AND. (.NOT.OPTION(4))) CALL EISGE(NMSUB, LLDS,
     +   LDSTAK, LDSMIN, 9, HEAD, ERROR(15), LLDS)
C
      IF (OPTION(4)) GO TO 40
C
      DO 30 I=1,15
         IF (ERROR(I)) GO TO 70
   30 CONTINUE
C
      RETURN
C
   40 CONTINUE
C
      CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERROR(16), LNF)
C
      CALL EISGE(NMSUB, LNW, NW, 1, 1, HEAD, ERROR(18), LNW)
C
      IF (ERROR(18)) GO TO 50
      IF (OPTION(3)) THEN
         CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, LAGMAX, 0,
     +      HEAD, 4, NV, ERROR(19), L1, LLAGMX)
      ELSE
         CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, N-1, 0,
     +      HEAD, 4, NV, ERROR(19), L1, LNM1)
      END IF
C
   50 CONTINUE
C
      CALL EISGE(NMSUB, LICSPC, ICSPC2, NF, 3, HEAD, ERROR(24), LNF)
C
      CALL EISGE(NMSUB, LIPHAS, IPHAS, NF, 3, HEAD, ERROR(25), LNF)
C
      IF (ERROR(2) .OR. ERROR(16) .OR. ERROR(18) .OR. ERROR(19)) GO TO
     +   70
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(30), LLDS)
C
      DO 60 I=1,30
         IF (ERROR(I)) GO TO 70
   60 CONTINUE
C
      RETURN
C
   70 CONTINUE
      IERR = 1
      RETURN
C
      END
*BFS
      SUBROUTINE BFS(Y1, Y2, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     BIVARIATE SPECTRUM ANALYSIS (SHORT 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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y1(*),Y2(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2
      INTEGER
     +   ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,IPRT,JCCOV,JNLPPC,
     +   LAGMAX,LAGMX1,LDSMIN,LDSTAK,LPCV,LW,LY,M,NF,NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   CCOV(101,2,2),CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101),
     +   PHAS(101,4),SPCF1(101),SPCF2(101),W(101),XAXIS(404),
     +   YAXIS(404)
      INTEGER
     +   ISYM(404),LAGS(4),NLPPC(1,1,1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,IPRINT,PARZEN,SETLAG
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL CCOV(101,2,2)
C        THE COVARIANCES.
C     REAL CEVEN(101)
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CODD(101)
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(101,4)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISYM(404)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC(1,1,1)
C        A DUMMY ARRAY.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(101,4)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL SPCF1(101), SPCF2(101)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL W(101)
C        THE WINDOWS.
C     REAL XAXIS(404)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YAXIS(404)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        DUMMY VARIABLES.
C     REAL Y1(N)
C        THE FIRST TIME SERIES.
C     REAL Y2(N)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .FALSE.
C
      ICCOV = 101
      JCCOV = 2
      M = 2
      INDEX1 = 1
      INDEX2 = 2
C
      ICSPC2 = 101
      IPHAS = 101
C
      LDSTAK = 0
      LDSMIN = 0
C
      NF = 101
      YMISS1 = 1.0E0
      YMISS2 = 1.0E0
      INLPPC = 1
      JNLPPC = 1
      LW = 101
      LY = N
      LPCV = 404
C
C     SET MAXIMUM LAG VALUE (LAGMAX)
C     SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW)
C
      CALL SETLAG(N, LAGMAX)
      NW = 4
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2,
     +   NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, LAGMX1, W, LW,
     +   DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD,
     +   CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC,
     +   JNLPPC, LY)
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL BFS (Y1, Y2, N)')
      END
*BFSF
      SUBROUTINE BFSF(YFFT1, YFFT2, N, LYFFT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     BIVARIATE SPECTRUM ANALYSIS (SHORT 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
     +   LDSTAK,LYFFT,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YFFT1(*),YFFT2(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2
      INTEGER
     +   ICCOV,ICSPC2,IFP,INDEX1,INDEX2,INLPPC,IPHAS,IPRT,JCCOV,
     +   JNLPPC,LAGMAX,LAGMX1,LDSMIN,LPCV,LW,LWORK,M,NALL0,NF,NFFT,
     +   NPRT,NW,WORK
C
C  LOCAL ARRAYS
      REAL
     +   CCOV(101,2,2),CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101),
     +   PHAS(101,4),RSTAK(12),SPCF1(101),SPCF2(101),W(101),
     +   XAXIS(404),YAXIS(404)
      INTEGER
     +   ISYM(404),LAGS(4),NLPPC(1,1,1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,SETESL,SETLAG,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL CCOV(101,2,2)
C        THE COVARIANCES.
C     REAL CEVEN(101)
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CODD(101)
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(101,4)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISYM(404)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTORS Y1 AND YFFT1 AND YFFT2
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS ON ENTRY
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NLPPC(1,1,1)
C        A DUMMY ARRAY.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(101,4)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCF1(101), SPCF2(101)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL W(101)
C        THE WINDOWS.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE WORK VECTOR
C     REAL XAXIS(404)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YAXIS(404)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        DUMMY VARIABLES.
C     REAL YFFT1(LYFFT)
C        THE FIRST TIME SERIES.
C     REAL YFFT2(LYFFT)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','F',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .TRUE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .FALSE.
C
      ICCOV = 101
      JCCOV = 2
      M = 2
      INDEX1 = 1
      INDEX2 = 2
C
      ICSPC2 = 101
      IPHAS = 101
C
      LDSMIN = 0
C
      NF = 101
      YMISS1 = 1.0E0
      YMISS2 = 1.0E0
      INLPPC = 1
      JNLPPC = 1
      LW = 101
      LPCV = 404
C
C     SET MAXIMUM LAG VALUE (LAGMAX)
C     SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW)
C     SET EXTENDED SERIES LENGTH (NFFT)
C
      CALL SETLAG(N, LAGMAX)
      NW = 4
      CALL SETESL(N+LAGMAX, 4, NFFT)
C
C     COMPUTE MINIMUM ALLOWABLE STACK LENGTH (LDSMIN)
C
      CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN)
C
C     SET SIZE OF WORK AREA
C     SET NUMBER OF OUTSTANDING ALLOCATIONS (NALL0)
C     SET THE STACK ALLOCATION TYPE (IFP)
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET THE STARTING LOCATIONS INTHE WORK AREA FOR VARIOUS ARRAYS
C
      IF ((LDSMIN.LE.LDSTAK) .AND. (LDSMIN.GE.7)) THEN
         WORK = STKGET(NFFT,IFP)
         LWORK = NFFT
      ELSE
         WORK = 1
         LWORK = 1
      END IF
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(YFFT1, YFFT2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1,
     +            SPCF2, NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS,
     +            LAGMX1, RSTAK(WORK), LWORK, DELTA, ISYM, XAXIS,
     +            YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV, JCCOV, M,
     +            INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD,
     +            CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, NFFT,
     +            INLPPC, JNLPPC, LYFFT)
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL BFSF (YFFT1, YFFT2, N, LYFFT, LDSTAK)')
      END
*BFSFS
      SUBROUTINE BFSFS(YFFT1, YFFT2, N, LYFFT, LDSTAK, NW, LAGS, NF,
     +   FMIN, FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS, FREQ)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     BIVARIATE SPECTRUM ANALYSIS (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
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ICSPC2,IPHAS,LDSTAK,LYFFT,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   CSPC2(*),FREQ(*),PHAS(*),YFFT1(*),YFFT2(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS1,YMISS2
      INTEGER
     +   CCOV,CCOV11,CCOV12,CCOV21,CCOV22,CEVEN,CODD,I,ICCOV,IFP,
     +   INDEX1,INDEX2,INLPPC,IO,IPRT,ISYM,JCCOV,JNLPPC,LAGMAX,
     +   LAGMX1,LDSMIN,LPCV,LW,LWORK,M,NALL0,NFFT,SPCF1,SPCF2,W,
     +   WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12),NLPPC(1,1,1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,SETESL,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     INTEGER CCOV, CCOV11, CCOV12, CCOV21, CCOV22
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE COVARIANCES.
C     INTEGER CEVEN
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     INTEGER CODD
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(ICSPC2,NW)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS ON ENTRY.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NLPPC(1,1,1)
C        A DUMMY ARRAY.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(IPHAS,NW)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SPCF1, SPCF2
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     INTEGER W
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE WINDOWS.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        DUMMY VARIABLES.
C     REAL YFFT1(LYFFT)
C        THE FIRST TIME SERIES.
C     REAL YFFT2(LYFFT)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','F','S',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .TRUE.
C
C     SET MAXIMUM LAG VALUE TO BE USED.
C
      IF (NW.GE.1) THEN
         LAGMAX = LAGS(1)
         DO 10 I=2,NW
            LAGMAX = MAX(LAGMAX,LAGS(I))
   10    CONTINUE
      ELSE
         LAGMAX = N - 1
      END IF
      LAGMX1 = LAGMAX + 1
      CALL SETESL(N+LAGMAX, 4, NFFT)
C
      ICCOV = LAGMAX + 1
      JCCOV = 2
      INLPPC = 1
      JNLPPC = 1
      M = 2
      INDEX1 = 1
      INDEX2 = 2
C
C     COMPUTE THE MINIMUM ALLOWABLE STACK AREA
C
      IF (NPRT.EQ.0) THEN
         IO = 0
      ELSE
         IO = 1
      END IF
C
      CALL LDSCMP(9, 0, IO*4*NF, 0, 0, 0, 'S',
     +            6*LAGMAX+6+NFFT+IO*8*NF, LDSMIN)
C
      YMISS1 = 1.0E0
      YMISS2 = 1.0E0
      LPCV = 4*NF
      LW = NFFT
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0)
C     SET THE STACK ALLOCATION TYPE (IFP)
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         CCOV = 1
         CEVEN = 1
         CODD = 1
         SPCF1 = 1
         SPCF2 = 1
         W = 1
C
         CCOV11 = 1
         CCOV21 = 1
         CCOV12 = 1
         CCOV22 = 1
C
         ISYM = 1
         XAXIS = 1
         YAXIS = 1
      ELSE
         CCOV = STKGET(4*LAGMX1,IFP)
         CEVEN = STKGET(LAGMX1,IFP)
         CODD = STKGET(LAGMX1,IFP)
         SPCF1 = STKGET(NF,IFP)
         SPCF2 = STKGET(NF,IFP)
         W = STKGET(LW,IFP)
C
         CCOV11 = CCOV
         CCOV21 = CCOV + LAGMX1
         CCOV12 = CCOV21 + LAGMX1
         CCOV22 = CCOV12 + LAGMX1
C
         IF (NPRT.EQ.0) THEN
            ISYM = W
            XAXIS = W
            YAXIS = W
         ELSE
            ISYM = STKGET(LPCV,2)
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
         END IF
      END IF
C
      WORK = W
      LWORK = LW
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(YFFT1, YFFT2, YMISS1, YMISS2, RSTAK(CCOV), NLPPC,
     +   RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW,
     +   LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM),
     +   RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS,
     +   RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN,
     +   LDSTAK, OPTION, NFFT, INLPPC, JNLPPC, LYFFT)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL BFSFS (YFFT1, YFFT2, N, LYFFT, LDSTAK,'/
     +   '      +            NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +   '      +            CSPC2, ICSPC2, PHAS, IPHAS, FREQ)')
      END
*BFSLAG
      SUBROUTINE BFSLAG(CCOV, LAGMAX, LAGS, N, NW, NWUSED, ICCOV,
     +   JCCOV, INDEX1, INDEX2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE LAG WINDOW TRUNCATION POINTS FOR
C     FOURIER BIVARIATE SPECTRUM ANALYSIS.
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
     +   ICCOV,INDEX1,INDEX2,JCCOV,LAGMAX,N,NW,NWUSED
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(ICCOV,JCCOV,*)
      INTEGER
     +   LAGS(*)
C
C  LOCAL SCALARS
      REAL
     +   COVMX,COVMXI,FAC11,FAC12,FAC21,FAC22,P95LIM
      INTEGER
     +   I,J,K,LAG,NWM1
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,REAL,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV(ICCOV,JCCOV,*)
C        THE COVARIANCES.
C     REAL COVMX
C        THE MAXIMUM COVARIANCE VALUE.
C     REAL COVMXI
C        THE MAXIMUM COVARIANCE VALUE FOR THE ITH LAG.
C     REAL FAC11, FAC12, FAC21, FAC22
C        FACTORS USED TO COMPUTE THE CORRELATION COEFFICIENTS.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER J
C        AN INDEX VALUE.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER K
C        AN INDEX VALUE.
C     INTEGER LAG, LAGMAX
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        BIVARIATE COVARIANCE BEING COMPUTED AND THE MAXIMUM LAG
C        TO BE USED, RESPECTIVELY.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NW
C        THE NUMBER OF DIFFERENT BANDWIDTHS REQUESTED.
C     INTEGER NWM1, NWUSED
C        THE NUMBER OF DIFFERENT BANDWIDTHS MINUS 1, AND THE
C        ACTUAL NUMBER OF BANDWIDTHS ACTUALLY USED.
C     REAL P95LIM
C        THE 95 PERCENT CONFIDENT LIMIT FOR WHITE NOISE.
C
      LAGS(NW) = LAGMAX
      IF (LAGS(NW).LE.32) GO TO 30
C
C     COMPUTE 95 PERCENT CONFIDENCE LIMITS ON BIVARIATECOVARIANCES,
C     ASSUMING WHITE NOISE.
C
      P95LIM = 1.96E0/SQRT(REAL(N))
C
      FAC11 = CCOV(1,INDEX1,INDEX1)
      FAC12 = SQRT(CCOV(1,INDEX1,INDEX1)*CCOV(1,INDEX2,INDEX2))
      FAC21 = FAC12
      FAC22 = CCOV(1,INDEX2,INDEX2)
C
C     CHECK FOR FIRST CVF EXCEEDING 95 PERCENT LIMIT ON WHITE NOISE
C
      DO 10 I=1,LAGMAX
         LAG = LAGMAX + 1 - I
         COVMXI = MAX(ABS(CCOV(LAG,INDEX1,INDEX1)*FAC11),ABS(CCOV(LAG,
     +      INDEX1,INDEX2)*FAC12),ABS(CCOV(LAG,INDEX2,INDEX1)*FAC21),
     +      ABS(CCOV(LAG,INDEX2,INDEX2)*FAC22))
         IF (COVMXI.GE.P95LIM) GO TO 30
         LAGS(NW) = LAGS(NW) - 1
   10 CONTINUE
C
C     IF NO ACVF EXCEEDS WHITE NOISE LIMITS, CHECK FOR LARGEST ACVF.
C
      LAGS(NW) = 1
      COVMX = ABS(CCOV(2,1,1)*FAC11)
      DO 20 LAG=1,LAGMAX
         COVMXI = MAX(ABS(CCOV(LAG,INDEX1,INDEX1)*FAC11),ABS(CCOV(LAG,
     +      INDEX1,INDEX2)*FAC12),ABS(CCOV(LAG,INDEX2,INDEX1)*FAC21),
     +      ABS(CCOV(LAG,INDEX2,INDEX2)*FAC22))
         IF (COVMXI.LE.COVMX) GO TO 20
         LAGS(NW) = LAG
         COVMX = COVMXI
   20 CONTINUE
C
C     COMPUTE LAG WINDOW TRUNCATION POINTS
C
   30 LAGS(NW) = LAGS(NW)*3.0E0/2.0E0
      IF (LAGS(NW).LT.32) LAGS(NW) = 32
      IF (LAGS(NW).GT.LAGMAX) LAGS(NW) = LAGMAX
      NWUSED = NW
      IF (NW.EQ.1) RETURN
      NWM1 = NW - 1
      DO 40 I=1,NWM1
         K = NW - I
         LAGS(K) = LAGS(K+1)/2
   40 CONTINUE
C
C     CHECK WHETHER ALL NW LAG WINDOW TRUNCATION POINTS CAN BE USED.
C
      NWUSED = NW
      IF (LAGS(1).GE.4) RETURN
C
C     RECONSTURCT -LAGS- VECTOR IF NOT ALL TRUNCATION POINTS ARE
C     TO BE USED
C
      DO 50 I=2,NW
         NWUSED = NWUSED - 1
         IF (LAGS(I).GE.4) GO TO 60
   50 CONTINUE
C
   60 DO 70 I=1,NWUSED
         J = NW - NWUSED + I
         LAGS(I) = LAGS(J)
   70 CONTINUE
C
      RETURN
      END
*BFSM
      SUBROUTINE BFSM(Y1, YMISS1, Y2, YMISS2, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE
C     FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS
C     (SHORT 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
      REAL
     +   YMISS1,YMISS2
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y1(*),Y2(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN
      INTEGER
     +   ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,IPRT,JCCOV,JNLPPC,
     +   LAGMAX,LAGMX1,LDSMIN,LDSTAK,LPCV,LW,LY,M,NF,NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   CCOV(101,2,2),CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101),
     +   PHAS(101,4),SPCF1(101),SPCF2(101),W(101),XAXIS(404),
     +   YAXIS(404)
      INTEGER
     +   ISYM(404),LAGS(4),NLPPC(101,2,2)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,ECVF,IPRINT,PARZEN,SETLAG
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL CCOV(101,2,2)
C        THE COVARIANCES.
C     REAL CEVEN(101)
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CODD(101)
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(101,4)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISYM(404)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC(101,2,2)
C        THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(101,4)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL SPCF1(101), SPCF2(101)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL W(101)
C        THE WINDOWS.
C     REAL XAXIS(404)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YAXIS(404)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        THE MISSING VALUE CODES
C     REAL Y1(N)
C        THE FIRST TIME SERIES.
C     REAL Y2(N)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','M',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .TRUE.
      OPTION(3) = .FALSE.
      OPTION(4) = .FALSE.
C
      ICCOV = 101
      JCCOV = 2
      M = 2
      INDEX1 = 1
      INDEX2 = 2
C
      ICSPC2 = 101
      IPHAS = 101
C
      LDSTAK = 0
      LDSMIN = 0
C
      NF = 101
      INLPPC = 101
      JNLPPC = 2
      LW = 101
      LY = N
      LPCV = 404
C
C     SET MAXIMUM LAG VALUE (LAGMAX)
C     SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW)
C
      CALL SETLAG(N, LAGMAX)
      NW = 4
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2,
     +   NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, LAGMX1, W, LW,
     +   DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD,
     +   CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC,
     +   JNLPPC, LY)
C
      IF (IERR.NE.0) THEN
        IF (IERR.EQ.2) CALL ECVF(NMSUB)
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL BFSM (Y1, YMISS1, Y2, YMISS2, N)')
      END
*BFSMN
      SUBROUTINE BFSMN(SPCF1, SPCF2, CEVEN, CODD, W, LW, LAG, DF, NPRT,
     +   NF, CSPC2, PHAS, FREQ, NPTS, XAXIS, YAXIS, ISYM, LPCV, ALPHA,
     +   LAGMX1, DELTA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE SQUARED COHERENCY AND PHASE COMPONENTS
C     OF A BIVARIATE SPECTRUM.
C
C     REFERENCE - JENKINS AND WATTS
C                 SPECTRAL ANALYSIS AND ITS APPLICATIONS
C
C     WRITTEN BY - STEPHEN M. KEEFER AND 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
      REAL
     +   ALPHA,DELTA,DF
      INTEGER
     +   LAG,LAGMX1,LPCV,LW,NF,NPRT,NPTS
C
C  ARRAY ARGUMENTS
      REAL
     +   CEVEN(*),CODD(*),CSPC2(*),FREQ(*),PHAS(*),SPCF1(*),SPCF2(*),
     +   W(*),XAXIS(*),YAXIS(*)
      INTEGER
     +   ISYM(*)
C
C  LOCAL SCALARS
      REAL
     +   ARG,BARL,BARQ,BARY,C,CI,FAC,FPLM,FPLRS,FPSPM,G,PI,PIT2,SN,V0,
     +   V1,V2,Z0,Z1,Z2
      INTEGER
     +   I,K
C
C  EXTERNAL FUNCTIONS
      REAL
     +   PPFNML,R1MACH
      EXTERNAL PPFNML,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ATAN2,COS,LOG,SIGN,SIN,SQRT,TANH
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL ARG
C        AN ARGUMENT USED IN THE SPECTRUM COMPUTATIONS.
C     REAL BARL
C        THE SMOOTHED COSPECTRAL ESTIMATES.
C     REAL BARQ
C        THE SMOOTHED QUADRATURE SPECTRAL ESTIMATES.
C     REAL BARY
C        A TRANSFORMATION OF THE SQUARED COHERENCY COMPONENT.
C     REAL C
C        AN ARGUMENT USED IN THE SPECTRUM COMPUTATIONS.
C     REAL CEVEN(LAGMX1)
C        THE SUMS OF THE COVARIANCES FOR EACH LAG.
C     REAL CI
C        THE CONFIDENCE INTERVAL FOR THE SQUARED COHERENCY COMPONENT.
C     REAL CODD(LAGMX1)
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(NF)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL DF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     REAL FAC
C        THE CONVERSION FACTOR FROM RADIANS TO DEGREES.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     REAL FPSPM
C        THE FLOATING POINT SMALLEST POSITIVE MAGNITUDE.
C     REAL FREQ(NF)
C        THE FREQUENCIES AT WHICH THE SPECTRUM IS COMPUTED.
C     REAL G
C        AN ARGUMENT USED IN THE COMPUTATION OF THE ALPHA PERCENT
C        SIGNIFICANCE LEVEL.
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER ISYM(LPCV)
C        THE VECTOR CONTAINING THE CODES FOR THE PLOT SYMBOLS.
C     INTEGER K
C         AN INDEX VALUE.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMX1
C        THE VALUE LAGMAX+1.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C         THE LENGTH OF VECTOR W.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT = 2 THE PLOT IS PROVIDED.
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     REAL PHAS(NF)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL PI, PIT2
C        THE VALUE OF PI AND PI*2.
C     REAL SN
C        AN ARGUMENT USED IN THE COMPUTATION OF THE SPECTRUM.
C     REAL SPCF1(NF), SPCF2(NF)
C        THE UNIVARIATE SPECTRUM FOR EACH SERIES.
C     REAL V0, V1, V2
C        ARGUMENTS USED IN THE COMPUTATION OF THE SPECTRUM.
C     REAL W(LW)
C        THE WINDOW.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL Z0, Z1, Z2
C        ARGUMENTS USED IN THE COMPUTATION OF THE SPECTRUM.
C
C
      CALL GETPI(PI)
      PIT2 = PI*2.0E0
C
      FPSPM = R1MACH(1)
      FPLM = R1MACH(2)
      FPLRS = R1MACH(4)
C
      FAC = 180.0E0/PI
C
C
C     COMPUTE SMOOTHED CO-SPECTRAL ESTIMATE
C
      DO 40 I=1,NF
C
C           COMPUTE SMOOTHED CO- AND QUADRATURE SPECTRA USING
C           THE ALGORITHM SHOWN ON PAGE 420 OF JENKINS AND WATTS
C
         IF (FREQ(I).EQ.0.0E0) THEN
            C = 1.0E0
            SN = 0.0E0
         ELSE IF (FREQ(I).EQ.0.25E0) THEN
            C = 0.0E0
            SN = 1.0E0
         ELSE IF (FREQ(I).EQ.0.5E0) THEN
            C = -1.0E0
            SN = 0.0
         ELSE
            ARG = PIT2*FREQ(I)
            C = COS(ARG)
            SN = SIN(ARG)
         END IF
         V0 = 0.0E0
         V1 = 0.0E0
         Z0 = 0.0E0
         Z1 = 0.0E0
         DO 10 K=LAG-1,1,-1
            V2 = 2.0E0*C*V1 - V0 + W(K+1)*CEVEN(K+1)
            Z2 = 2.0E0*C*Z1 - Z0 + W(K+1)*CODD(K+1)
            V0 = V1
            V1 = V2
            Z0 = Z1
            Z1 = Z2
   10    CONTINUE
         BARL = DELTA*(CEVEN(1)+2.0E0*(V1*C-V0))
         BARQ = 2.0E0*DELTA*Z1*SN
C
C     COMPUTE THE SMOOTHED SQUARED COHERENCY SPECTRA
C
         IF (SPCF1(I)*SPCF2(I).GT.0.0E0) THEN
            CSPC2(I) = (BARL*BARL+BARQ*BARQ)
            CSPC2(I) = CSPC2(I)/(SPCF1(I)*SPCF2(I))
         ELSE
            CSPC2(I) = FPLM
         END IF
C
C     COMPUTE PHASE (IN RADIANS)
C
         IF ((BARQ.NE.0.0E0) .OR. (BARL.NE.0.0E0)) THEN
            PHAS(I) = ATAN2(-BARQ,BARL)
         ELSE
            IF (I.EQ.1) THEN
               PHAS(I) = 0.0E0
            ELSE
               PHAS(I) = SIGN(PI,PHAS(I-1))
            END IF
         END IF
   40 CONTINUE
C
      IF (NPRT.EQ.0) RETURN
C
C     COMPUTE SMOOTHED SQUARED COHERENCY PLOT VECTORS
C
      CI = PPFNML(ALPHA)*SQRT(1.0E0/DF)
      G = 2.0E0/DF
      G = 1.0E0 - (1.0E0-ALPHA)**(G/(1.0E0-G))
      NPTS = 0
      DO 60 I=1,NF
         NPTS = NPTS + 1
C
C     COMPUTE 95 PER CENT SIGNIFICANCE LEVEL
C
         YAXIS(NPTS) = G
         XAXIS(NPTS) = FREQ(I)
         ISYM(NPTS) = 4
         IF (SPCF1(I)*SPCF2(I).LE.0.0E0) GO TO 60
C
C     COMPUTE COHERENCE SPECTRAL ESTIMATE
C
         IF (CSPC2(I).GT.1.0E0) GO TO 60
         NPTS = NPTS + 1
         YAXIS(NPTS) = CSPC2(I)
         XAXIS(NPTS) = FREQ(I)
         ISYM(NPTS) = 1
         IF (CSPC2(I).LT.G) GO TO 60
C
C     COMPUTE CONFIDENCE INTERVAL
C
         BARY = SQRT(CSPC2(I))
         BARY = 0.5E0*(LOG((1.0E0+BARY)/(1.0E0-BARY)))
         NPTS = NPTS + 1
         YAXIS(NPTS) = (TANH(BARY+CI))*(TANH(BARY+CI))
         XAXIS(NPTS) = FREQ(I)
         ISYM(NPTS) = 2
         NPTS = NPTS + 1
         YAXIS(NPTS) = (TANH(BARY-CI))*(TANH(BARY-CI))
         XAXIS(NPTS) = FREQ(I)
         ISYM(NPTS) = 2
   60 CONTINUE
C
      RETURN
C
      END
*BFSMS
      SUBROUTINE BFSMS (Y1, YMISS1, Y2, YMISS2, N, NW, LAGS, NF, FMIN,
     +   FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE
C     FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS
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
      REAL
     +   FMAX,FMIN,YMISS1,YMISS2
      INTEGER
     +   ICSPC2,IPHAS,LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   CSPC2(*),FREQ(*),PHAS(*),Y1(*),Y2(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA
      INTEGER
     +   CCOV,CEVEN,CODD,I,ICCOV,IFP,INDEX1,INDEX2,INLPPC,IO,IPRT,
     +   ISYM,JCCOV,JNLPPC,LAGMAX,LAGMX1,LDSMIN,LPCV,LW,LWORK,LY,M,
     +   NALL0,NLPPC,SPCF1,SPCF2,W,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     INTEGER CCOV
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE COVARIANCES.
C     INTEGER CEVEN
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     INTEGER CODD
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(ICSPC2,NW)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS ON ENTRY.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC
C        THE STARTING LOCATION IN THE WORK AREA FOR NLPPC
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(IPHAS,NW)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SPCF1, SPCF2
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     INTEGER W
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE WINDOWS.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        DUMMY VARIABLES.
C     REAL Y1(N)
C        THE FIRST TIME SERIES.
C     REAL Y2(N)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','M','S',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .TRUE.
      OPTION(3) = .FALSE.
      OPTION(4) = .TRUE.
C
C     SET MAXIMUM LAG VALUE TO BE USED (LAGMAX).
C
      LAGMAX = N - 1
      IF (NW.LE.0) GO TO 20
      LAGMAX = LAGS(1)
      DO 10 I=1,NW
         LAGMAX = MAX(LAGMAX,LAGS(I))
   10 CONTINUE
   20 CONTINUE
      LAGMX1 = LAGMAX + 1
C
      ICCOV = LAGMAX + 1
      JCCOV = 2
      INLPPC = LAGMAX + 1
      JNLPPC = 2
      M = 2
      INDEX1 = 1
      INDEX2 = 2
C
C     COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN)
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(10, 0, 4*LAGMAX + 4 + IO*4*NF, 0, 0, 0, 'S',
     +  7*LAGMAX+7+2*NF+IO*8*NF, LDSMIN)
C
      LY = N
      LPCV = 4*NF
      LW = LAGMX1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0).
C     SET THE STACK ALLOCATION TYPE (IFP)
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         CCOV = 1
         NLPPC = 1
         CEVEN = 1
         CODD = 1
         SPCF1 = 1
         SPCF2 = 1
         W = 1
C
         ISYM = 1
         XAXIS = 1
         YAXIS = 1
      ELSE
         CCOV = STKGET(4*LAGMX1,IFP)
         NLPPC = STKGET(4*LAGMX1,2)
         CEVEN = STKGET(LAGMX1,IFP)
         CODD = STKGET(LAGMX1,IFP)
         SPCF1 = STKGET(NF,IFP)
         SPCF2 = STKGET(NF,IFP)
         W = STKGET(LW,IFP)
         IF (NPRT.EQ.0) THEN
            ISYM = W
            XAXIS = W
            YAXIS = W
         ELSE
            ISYM = STKGET(LPCV,2)
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
         END IF
      END IF
C
      WORK = W
      LWORK = LW
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, RSTAK(CCOV), ISTAK(NLPPC),
     +   RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW,
     +   LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM),
     +   RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS,
     +   RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN,
     +   LDSTAK, OPTION, N, INLPPC, JNLPPC, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.NE.0) THEN
        IF (IERR.EQ.2) CALL ECVF(NMSUB)
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL BFSMS (Y1, YMISS1, Y2, YMISS2, N,'/
     +  '      +            NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +  '      +            CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)')
      END
*BFSMV
      SUBROUTINE BFSMV(CCOV, NLPPC, INDEX1, INDEX2, N, LAGMAX, ICCOV,
     +  JCCOV, INLPPC, JNLPPC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE
C     FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS
C     AND COVARIANCES INPUT RATHER THAN ORIGINAL SERIES
C     (SHORT 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
     +   ICCOV,INDEX1,INDEX2,INLPPC,JCCOV,JNLPPC,LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*)
      INTEGER
     +   NLPPC(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2
      INTEGER
     +   ICSPC2,IPHAS,IPRT,LAGMX1,LAGMXU,LDSMIN,LDSTAK,LPCV,LW,LY,
     +   M,NF,NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101),PHAS(101,4),
     +   SPCF1(101),SPCF2(101),W(101),XAXIS(404),Y1(1),Y2(1),
     +   YAXIS(404)
      INTEGER
     +   ISYM(404),LAGS(4)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,ECVF,IPRINT,PARZEN,SETLAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL CCOV(ICCOV,JCCOV,*)
C        THE COVARIANCES.
C     REAL CEVEN(101)
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CODD(101)
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(101,4)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISYM(404)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC.
C     INTEGER LAGMAX, LAGMXU
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC(INLPPC,JNLPPC,*)
C        THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(101,4)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL SPCF1(101), SPCF2(101)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL W(101)
C        THE WINDOWS.
C     REAL XAXIS(404)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YAXIS(404)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        THE MISSING VALUE CODES
C     REAL Y1(1)
C        THE FIRST TIME SERIES.
C     REAL Y2(1)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','M','V',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .TRUE.
      OPTION(3) = .TRUE.
      OPTION(4) = .FALSE.
C
      M = 2
C
      ICSPC2 = 101
      IPHAS = 101
C
      LDSTAK = 0
      LDSMIN = 0
C
      NF = 101
      LW = 101
      LY = N
      LPCV = 404
C
C     SET MAXIMUM LAG VALUE USED (LAGMXU)
C     SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW)
C
      CALL SETLAG(N, LAGMXU)
      LAGMXU = MIN(LAGMXU,LAGMAX)
      NW = 4
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2,
     +   NF, FMIN, FMAX, FREQ, N, NW, LAGMXU, LAGS, LAGMX1, W, LW,
     +   DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD,
     +   CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC,
     +   JNLPPC, LY)
C
      IF (IERR.NE.0) THEN
        IF (IERR.EQ.2) CALL ECVF(NMSUB)
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL BFSMV (CCOV, NLPPC, INDEX1, INDEX2, N, LAGMAX,'/
     +   '      +            ICCOV, JCCOV, INLPPC, JNLPPC)')
      END
*BFSMVS
      SUBROUTINE BFSMVS(CCOV, NLPPC, INDEX1, INDEX2, N, ICCOV, JCCOV,
     +   INLPPC, JNLPPC, NW, LAGS, NF, FMIN,
     +   FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE
C     FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS
C     WITH USER INPUT OF THE COVARIANCES RATHER THAN THE SERIES
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
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,JCCOV,JNLPPC,
     +   LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*),CSPC2(*),FREQ(*),PHAS(*)
      INTEGER
     +   LAGS(*),NLPPC(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS1,YMISS2
      INTEGER
     +   CEVEN,CODD,I,IFP,IO,IPRT,ISYM,LAGMAX,LAGMX1,LDSMIN,LPCV,
     +   LW,LWORK,LY,M,NALL0,SPCF1,SPCF2,W,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12),Y1(1),Y2(1)
      INTEGER
     +   ISTAK(12)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL CCOV(ICCOV,JCCOV,*)
C        THE COVARIANCES.
C     INTEGER CEVEN
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     INTEGER CODD
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(ICSPC2,NW)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS ON ENTRY.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC(INLPPC,JNLPPC,*)
C        THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(IPHAS,NW)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SPCF1, SPCF2
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     INTEGER W
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE WINDOWS.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        DUMMY VARIABLES.
C     REAL Y1(1)
C        THE FIRST TIME SERIES.
C     REAL Y2(1)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','M','V','S'/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .TRUE.
      OPTION(3) = .TRUE.
      OPTION(4) = .TRUE.
C
C     SET MAXIMUM LAG VALUE TO BE USED (LAGMAX).
C
      LAGMAX = N - 1
      IF (NW.LE.0) GO TO 20
      LAGMAX = LAGS(1)
      DO 10 I=1,NW
         LAGMAX = MAX(LAGMAX,LAGS(I))
   10 CONTINUE
   20 CONTINUE
      LAGMX1 = LAGMAX + 1
C
      M = 2
C
C     COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN)
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(8, 0, IO*4*NF, 0, 0, 0, 'S',
     +  7*LAGMAX+7+2*NF+IO*8*NF, LDSMIN)
C
      LY = N
      LPCV = 4*NF
      LW = LAGMAX + 1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0).
C     SET THE STACK ALLOCATION TYPE (IFP)
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         CEVEN = 1
         CODD = 1
         SPCF1 = 1
         SPCF2 = 1
         W = 1
C
         ISYM = 1
         XAXIS = 1
         YAXIS = 1
      ELSE
         CEVEN = STKGET(LAGMX1,IFP)
         CODD = STKGET(LAGMX1,IFP)
         SPCF1 = STKGET(NF,IFP)
         SPCF2 = STKGET(NF,IFP)
         W = STKGET(LW,IFP)
         IF (NPRT.EQ.0) THEN
            ISYM = W
            XAXIS = W
            YAXIS = W
         ELSE
            ISYM = STKGET(LPCV,2)
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
         END IF
      END IF
C
      WORK = W
      LWORK = LW
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC,
     +   RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW,
     +   LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM),
     +   RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS,
     +   RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN,
     +   LDSTAK, OPTION, N, INLPPC, JNLPPC, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.NE.0) THEN
        IF (IERR.EQ.2) CALL ECVF(NMSUB)
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL BFSMVS(CCOV, NLPPC, INDEX1, INDEX2, N,'/
     +   '      +            ICCOV, JCCOV, INLPPC, JNLPPC,'/
     +   '      +            NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +   '      +            CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)')
      END
*BFSS
      SUBROUTINE BFSS(Y1, Y2, N, NW, LAGS, NF, FMIN, FMAX, NPRT, CSPC2,
     +   ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     BIVARIATE SPECTRUM ANALYSIS (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
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ICSPC2,IPHAS,LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   CSPC2(*),FREQ(*),PHAS(*),Y1(*),Y2(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS1,YMISS2
      INTEGER
     +   CCOV,CCOV11,CCOV12,CCOV21,CCOV22,CEVEN,CODD,I,ICCOV,IFP,
     +   INDEX1,INDEX2,INLPPC,IO,IPRT,ISYM,JCCOV,JNLPPC,LAGMAX,
     +   LAGMX1,LDSMIN,LPCV,LW,LWORK,LY,M,NALL0,SPCF1,SPCF2,W,WORK,
     +   XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12),NLPPC(1,1,1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     INTEGER CCOV, CCOV11, CCOV12, CCOV21, CCOV22
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE COVARIANCES.
C     INTEGER CEVEN
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     INTEGER CODD
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(ICSPC2,NW)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS ON ENTRY.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC(1,1,1)
C        A DUMMY ARRAY.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT = 1 THE PLOT IS PROVIDED.
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(IPHAS,NW)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SPCF1, SPCF2
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     INTEGER W
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE WINDOWS.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        DUMMY VARIABLES.
C     REAL Y1(N)
C        THE FIRST TIME SERIES.
C     REAL Y2(N)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','S',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .TRUE.
C
C     SET MAXIMUM LAG VALUE TO BE USED (LAGMAX).
C
      IF (NW.GE.1) THEN
         LAGMAX = LAGS(1)
         DO 10 I=1,NW
            LAGMAX = MAX(LAGMAX,LAGS(I))
   10    CONTINUE
      ELSE
         LAGMAX = N - 1
      END IF
      LAGMX1 = LAGMAX + 1
C
      ICCOV = LAGMAX + 1
      JCCOV = 2
      INLPPC = 1
      JNLPPC = 1
      M = 2
      INDEX1 = 1
      INDEX2 = 2
C
C     COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN)
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(9, 0, IO*4*NF, 0, 0, 0, 'S',
     +            7*LAGMAX+7+IO*8*NF, LDSMIN)
C
      LY = N
      YMISS1 = 1.0E0
      YMISS2 = 1.0E0
      LPCV = 4*NF
      LW = LAGMAX + 1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0).
C     SET THE STACK ALLOCATION TYPE (IFP)
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         CCOV = 1
         CEVEN = 1
         CODD = 1
         SPCF1 = 1
         SPCF2 = 1
         W = 1
C
         CCOV11 = 1
         CCOV21 = 1
         CCOV12 = 1
         CCOV22 = 1
C
         ISYM = 1
         XAXIS = 1
         YAXIS = 1
      ELSE
         CCOV = STKGET(4*LAGMX1,IFP)
         CEVEN = STKGET(LAGMX1,IFP)
         CODD = STKGET(LAGMX1,IFP)
         SPCF1 = STKGET(NF,IFP)
         SPCF2 = STKGET(NF,IFP)
         W = STKGET(LW,IFP)
C
         CCOV11 = CCOV
         CCOV21 = CCOV + LAGMX1
         CCOV12 = CCOV21 + LAGMX1
         CCOV22 = CCOV12 + LAGMX1
C
         IF (NPRT.EQ.0) THEN
            ISYM = W
            XAXIS = W
            YAXIS = W
         ELSE
            ISYM = STKGET(LPCV,2)
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
        END IF
      END IF
C
      WORK = W
      LWORK = LW
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, RSTAK(CCOV), NLPPC,
     +   RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW,
     +   LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM),
     +   RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS,
     +   RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN,
     +   LDSTAK, OPTION, N, INLPPC, JNLPPC, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL BFSS (Y1, Y2, N,'/
     +   '      +           NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +   '      +           CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)')
      END
*BFSV
      SUBROUTINE BFSV(CCOV, INDEX1, INDEX2, N, LAGMAX, ICCOV, JCCOV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE
C     FOURIER SPECTRUM ANALYSIS OF SERIES WITH
C     COVARIANCES INPUT RATHER THAN ORIGINAL SERIES
C     (SHORT 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
     +   ICCOV,INDEX1,INDEX2,JCCOV,LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2
      INTEGER
     +   ICSPC2,INLPPC,IPHAS,IPRT,JNLPPC,LAGMX1,LAGMXU,LDSMIN,
     +   LDSTAK,LPCV,LW,LY,M,NF,NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101),PHAS(101,4),
     +   SPCF1(101),SPCF2(101),W(101),XAXIS(404),Y1(1),Y2(1),
     +   YAXIS(404)
      INTEGER
     +   ISYM(404),LAGS(4),NLPPC(1,1,1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,IPRINT,PARZEN,SETLAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL CCOV(ICCOV,JCCOV,*)
C        THE COVARIANCES.
C     REAL CEVEN(101)
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CODD(101)
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(101,4)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISYM(404)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC.
C     INTEGER LAGMAX, LAGMXU
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC(1,1,1)
C        A DUMMY ARRAY.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(101,4)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL SPCF1(101), SPCF2(101)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL W(101)
C        THE WINDOWS.
C     REAL XAXIS(404)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YAXIS(404)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        THE MISSING VALUE CODES
C     REAL Y1(1)
C        THE FIRST TIME SERIES.
C     REAL Y2(1)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','V',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .TRUE.
      OPTION(4) = .FALSE.
C
      M = 2
C
      INLPPC = 1
      JNLPPC = 1
      ICSPC2 = 101
      IPHAS = 101
C
      LDSTAK = 0
      LDSMIN = 0
C
      NF = 101
      LW = 101
      LY = N
      LPCV = 404
C
C     SET MAXIMUM LAG VALUE USED (LAGMXU)
C     SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW)
C
      CALL SETLAG(N, LAGMXU)
      LAGMXU = MIN(LAGMXU,LAGMAX)
      NW = 4
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2,
     +   NF, FMIN, FMAX, FREQ, N, NW, LAGMXU, LAGS, LAGMX1, W, LW,
     +   DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD,
     +   CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC,
     +   JNLPPC, LY)
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL BFSV(CCOV, INDEX1, INDEX2, N, LAGMAX, ICCOV,',
     +  ' JCCOV)')
      END
*BFSVS
      SUBROUTINE BFSVS(CCOV, INDEX1, INDEX2, N, ICCOV, JCCOV,
     +   NW, LAGS, NF, FMIN, FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS,
     +   FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE
C     FOURIER SPECTRUM ANALYSIS OF SERIES WITH
C     USER INPUT OF THE COVARIANCES RATHER THAN THE SERIES
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
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ICCOV,ICSPC2,INDEX1,INDEX2,IPHAS,JCCOV,LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*),CSPC2(*),FREQ(*),PHAS(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS1,YMISS2
      INTEGER
     +   CEVEN,CODD,I,IFP,INLPPC,IO,IPRT,ISYM,JNLPPC,LAGMAX,LAGMX1,
     +   LDSMIN,LPCV,LW,LWORK,LY,M,NALL0,SPCF1,SPCF2,W,WORK,XAXIS,
     +   YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12),Y1(1),Y2(1)
      INTEGER
     +   ISTAK(12),NLPPC(1,1,1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL CCOV(ICCOV,JCCOV,*)
C        THE COVARIANCES.
C     INTEGER CEVEN
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG.
C     INTEGER CODD
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG.
C     REAL CSPC2(ICSPC2,NW)
C        THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
C     INTEGER ICSPC2
C        THE FIRST DIMENSION OF THE ARRAY CSPC2.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INDEX1, INDEX2
C        THE INDICES OF THE COVARIANCES OF THE TWO SERIES.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPHAS
C        THE FIRST DIMENSION OF THE ARRAY PHAS.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER JCCOV
C        THE SECOND DIMENSION OF THE ARRAY CCOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGMX1
C        LAGMAX+1.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER LY
C        THE LENGTH OF THE VECTORS Y1 AND Y2.
C     INTEGER M
C        THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE
C        COMPUTED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS ON ENTRY.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPC(1,1,1)
C        THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT.
C        IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        IF NPRT = 0 THE PLOT IS SUPPRESSED.
C        IF NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL PHAS(IPHAS,NW)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SPCF1, SPCF2
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     INTEGER W
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE WINDOWS.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOTS.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMISS1, YMISS2
C        DUMMY VARIABLES.
C     REAL Y1(1)
C        THE FIRST TIME SERIES.
C     REAL Y2(1)
C        THE SECOND TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'B','F','S','V','S',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .TRUE.
      OPTION(4) = .TRUE.
C
C     SET MAXIMUM LAG VALUE TO BE USED (LAGMAX).
C
      LAGMAX = N - 1
      IF (NW.LE.0) GO TO 20
      LAGMAX = LAGS(1)
      DO 10 I=1,NW
         LAGMAX = MAX(LAGMAX,LAGS(I))
   10 CONTINUE
   20 CONTINUE
      LAGMX1 = LAGMAX + 1
C
      M = 2
C
C     COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN)
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(8, 0, IO*4*NF, 0, 0, 0, 'S',
     +  3*LAGMAX+3+2*NF+IO*8*NF, LDSMIN)
C
      INLPPC = 1
      JNLPPC = 1
      LY = N
      LPCV = 4*NF
      LW = LAGMAX + 1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0).
C     SET THE STACK ALLOCATION TYPE (IFP)
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         CEVEN = 1
         CODD = 1
         SPCF1 = 1
         SPCF2 = 1
         W = 1
         ISYM = W
         XAXIS = W
         YAXIS = W
      ELSE
         CEVEN = STKGET(LAGMX1,IFP)
         CODD = STKGET(LAGMX1,IFP)
         SPCF1 = STKGET(NF,IFP)
         SPCF2 = STKGET(NF,IFP)
         W = STKGET(LW,IFP)
         IF (NPRT.EQ.0) THEN
            ISYM = W
            XAXIS = W
            YAXIS = W
         ELSE
            ISYM = STKGET(LPCV,2)
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
         END IF
      END IF
C
      WORK = W
      LWORK = LW
C
C     CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES
C
      CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC,
     +   RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW,
     +   LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM),
     +   RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV,
     +   JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS,
     +   RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN,
     +   LDSTAK, OPTION, N, INLPPC, JNLPPC, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL BFSVS(CCOV, INDEX1, INDEX2, N, ICCOV, JCCOV,'/
     + '      +           NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     + '      +           CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)')
      END
*CCFER
      SUBROUTINE CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV,
     +  INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR THE CCF FAMILY
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
     +   ICCOV,INLPPC,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX,LDSMIN,LDSTAK,
     +   LYFFT,M,N,NFFT
      LOGICAL
     +   ISFFT,ISLONG
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERR(15)
      CHARACTER
     +   LICCOV(8)*1,LINLPP(8)*1,LIYM(8)*1,LIYMFF(8)*1,
     +   LJCCOV(8)*1,LJNLPP(8)*1,LLAGMX(8)*1,LLDS(8)*1,
     +   LLGMX1(8)*1,LLYFFT(8)*1,LM(8)*1,LN(8)*1,LNFFT(8)*1,
     +   LNM1(8)*1,LONE(8)*1,LTHREE(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR(15)
C        VALUES 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 ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
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     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     LOGICAL ISLONG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE)
C     INTEGER IYM, IYMFFT
C        THE FIRST DIMENSION OF THE ARRAYS YM AND YMFFT, RESPECTIVELY.
C     INTEGER JCCOV, JNLPPC
C        THE SECOND DIMENSIONS OF THE ARRAYS CCOV AND NLPPC,
C        RESPECTIVELY.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
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 LICCOV(8), LINLPP(8), LIYM(8), LIYMFF(8), LJCCOV(8),
C    *  LJNLPP(8), LLAGMX(8), LLDS(8), LLGMX1(8), LLYFFT(8),
C    *  LM(8), LN(8), LNFFT(8), LNM1(8), LONE(8), LTHREE(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER M
C        THE NUMBER OF SERIES BEING ANALYZED
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C
C     SET UP NAME ARRAYS
C
      DATA
     + LICCOV(1), LICCOV(2), LICCOV(3), LICCOV(4), LICCOV(5),
     + LICCOV(6), LICCOV(7), LICCOV(8) /'I','C','C','O','V',' ',' ',' '/
      DATA
     + LINLPP(1), LINLPP(2), LINLPP(3), LINLPP(4), LINLPP(5),
     + LINLPP(6), LINLPP(7), LINLPP(8) /'I','N','L','P','P','C',' ',' '/
      DATA
     + LIYM(1), LIYM(2), LIYM(3), LIYM(4), LIYM(5),
     + LIYM(6), LIYM(7), LIYM(8) /'I','Y','M',' ',' ',' ',' ',' '/
      DATA
     + LIYMFF(1), LIYMFF(2), LIYMFF(3), LIYMFF(4), LIYMFF(5),
     + LIYMFF(6), LIYMFF(7), LIYMFF(8) /'I','Y','M','F','F','T',' ',' '/
      DATA
     + LJCCOV(1), LJCCOV(2), LJCCOV(3), LJCCOV(4), LJCCOV(5),
     + LJCCOV(6), LJCCOV(7), LJCCOV(8) /'J','C','C','O','V',' ',' ',' '/
      DATA
     + LJNLPP(1), LJNLPP(2), LJNLPP(3), LJNLPP(4), LJNLPP(5),
     + LJNLPP(6), LJNLPP(7), LJNLPP(8) /'J','N','L','P','P','C',' ',' '/
      DATA
     + LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5),
     + LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ',' '/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5),
     + LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+','1'/
      DATA
     + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     + LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ',' '/
      DATA
     + LM(1), LM(2), LM(3), LM(4), LM(5),
     + LM(6), LM(7), LM(8) /'M',' ',' ',' ',' ',' ',' ',' '/
      DATA
     + LN(1), LN(2), LN(3), LN(4), LN(5),
     + LN(6), LN(7), LN(8) /'N',' ',' ',' ',' ',' ',' ',' '/
      DATA
     + LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5),
     + LNM1(6), LNM1(7), LNM1(8) /'(','N','-','1',')',' ',' ',' '/
      DATA
     + LNFFT(1), LNFFT(2), LNFFT(3), LNFFT(4), LNFFT(5),
     + LNFFT(6), LNFFT(7), LNFFT(8) /'N','F','F','T',' ',' ',' ',' '/
      DATA
     + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5),
     + LONE(6), LONE(7), LONE(8) /'O','N','E',' ',' ',' ',' ',' '/
      DATA
     + LTHREE(1), LTHREE(2), LTHREE(3), LTHREE(4), LTHREE(5),
     + LTHREE(6), LTHREE(7), LTHREE(8) /'T','H','R','E','E',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
      DO 10 I = 1, 15
        ERR(I) = .FALSE.
   10 CONTINUE
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, ERR(1), LTHREE)
C
      CALL EISGE(NMSUB, LM, M, 1, 2, HEAD, ERR(2), LONE)
C
      IF (.NOT.ERR(1)) THEN
C
        CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(3), LONE,
     +    LNM1)
C
        IF (ISFFT) THEN
          IF (ISLONG) THEN
            CALL EISGE(NMSUB, LIYMFF, IYMFFT, NFFT, 3, HEAD, ERR(4),
     +        LNFFT)
          ELSE
            CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 3, HEAD, ERR(4),
     +        LNFFT)
          END IF
        ELSE
          CALL EISGE(NMSUB, LIYM, IYM, N, 3, HEAD, ERR(4), LN)
        END IF
C
        IF (.NOT.ERR(3)) THEN
C
          IF (ISLONG) THEN
            CALL EISGE(NMSUB, LICCOV, ICCOV, LAGMAX+1, 3, HEAD, ERR(5),
     +        LLGMX1)
            CALL EISGE(NMSUB, LJCCOV, JCCOV, M, 3, HEAD, ERR(6),
     +        LLGMX1)
            CALL EISGE(NMSUB, LINLPP, INLPPC, LAGMAX+1, 3, HEAD, ERR(7),
     +        LLGMX1)
            CALL EISGE(NMSUB, LJNLPP, JNLPPC, M, 3, HEAD, ERR(8),
     +        LLGMX1)
          END IF
C
          CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(9), LLDS)
C
        END IF
      END IF
C
      DO 20 I = 1, 15
        IF (ERR(I)) IERR = 1
   20 CONTINUE
C
      RETURN
C
      END
*CCF
      SUBROUTINE CCF (Y1, Y2, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS
C     CORRELATIONS OF TWO TIME SERIES (SHORT CALL).
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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y1(*),Y2(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   Y1MEAN,Y1SD,Y2MEAN,Y2SD
      INTEGER
     +   ICCOV,INLPPC,IPRT,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX,LDSMIN,
     +   LDSTAK,LYFFT,M,NFFT
      LOGICAL
     +   ISFFT,ISLONG
C
C  LOCAL ARRAYS
      REAL
     +   CCOV(101,2,2),RHOC(201),SDRHOC(201)
      INTEGER
     +   NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVF,CCFER,CCFMN,CCFOUT,IPRINT,SETLAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV(101, 2, 2)
C        THE CCVF MATRIX.
C     INTEGER ICCOV
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
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 INLPPC
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC
C        IN THE USERS PROGRAM.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     LOGICAL ISLONG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE)
C     INTEGER IYM
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER IYMFFT
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JCCOV
C        THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED
C        IN THE USERS PROGRAM.
C     INTEGER LAGMAX
C        THE NUMBER OF AUTOCORRELATIONS DESIRED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER M
C        THE NUMBER OF SERIES BEING COMPARED, IE THE
C        NUMBER OF COLUMNS OF DATA IN YM.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NDUM(1)
C        A DUMMY DIMENSIONED VARIABLE.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     REAL RHOC(201)
C        THE ARRAY CONTAINING THE CCF.
C     REAL SDRHOC(201)
C        THE ARRAY CONTAINING THE SD OF THE CCF.
C     REAL Y1(N), Y1MEAN, Y1SD
C        THE FIRST SERIES, AND ITS MEAN AND STANDARD DEVIATION.
C     REAL Y2(N), Y2MEAN, Y2SD
C        THE SECOND SERIES, AND ITS MEAN AND STANDARD DEVIATION.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'C',       'C',       'F',       ' ',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      ICCOV = 101
      INLPPC = 1
      IYM = N
      JCCOV = 2
      JNLPPC = 1
      LDSMIN = 0
      LDSTAK = 0
      LAGMAX = 1
      LYFFT = N + LAGMAX
      IYMFFT = LYFFT
      M = 2
      NFFT = N
      ISFFT = .FALSE.
      ISLONG = .FALSE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV,
     +  INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET THE MAXIMUM LAG VALUE TO BE USED.
C
        CALL SETLAG (N, LAGMAX)
C
C       COMPUTE THE SERIES ACVF AND SD
C
        CALL ACVF (Y1, N, Y1MEAN, CCOV(1,1,1), LAGMAX, 101)
        Y1SD = SQRT(CCOV(1,1,1) * N / (N-1))
C
        CALL ACVF (Y2, N, Y2MEAN, CCOV(1,2,2), LAGMAX, 101)
        Y2SD = SQRT(CCOV(1,2,2) * N / (N-1))
C
C       CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
        IF (CCOV(1,1,1)*CCOV(1,2,2) .NE. 0.0E0)
     +    CALL CCFMN (Y1, Y2, N, LAGMAX, 2*LAGMAX+1, CCOV(1,1,1),
     +     CCOV(1,2,2), CCOV(1,1,2), CCOV(1,2,1), 101, Y1MEAN, Y2MEAN,
     +     RHOC, SDRHOC, 1)
C
C       CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
        CALL CCFOUT (1, Y1MEAN, Y1SD, N, N, 2, Y2MEAN, Y2SD, N,
     +     N, LAGMAX, 2*LAGMAX+1, RHOC, SDRHOC, .FALSE., NDUM, NDUM, 1,
     +     0.0E0, 0.0E0, .FALSE.)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   27H       CALL CCF (Y1, Y2, N))
      END
*CCFF
      SUBROUTINE CCFF (YFFT1, YFFT2, N, LYFFT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS
C     CORRELATIONS OF TWO TIME SERIES USING THE SINGLETON FFT
C     (SHORT CALL).
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
     +   LDSTAK,LYFFT,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YFFT1(*),YFFT2(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   Y1MEAN,Y1SD,Y2MEAN,Y2SD
      INTEGER
     +   ICCOV,IFP,INLPPC,IPRT,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX,
     +   LDSMIN,M,NALL0,NFFT,WORK
      LOGICAL
     +   ISFFT,ISLONG
C
C  LOCAL ARRAYS
      REAL
     +   CCOV(101,2,2),RHOC(201),RSTAK(12),SDRHOC(201),STAK(12)
      INTEGER
     +   NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVFF,CCFER,CCFMNF,CCFOUT,FFTLEN,IPRINT,LDSCMP,SETLAG,
     +   STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),STAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV(101, 2, 2)
C        THE CCVF MATRIX.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ICCOV
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INLPPC
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC
C        IN THE USERS PROGRAM.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     LOGICAL ISLONG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE)
C     INTEGER IYMFFT
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JCCOV
C        THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED
C        IN THE USERS PROGRAM.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE NUMBER OF LOCATIONS IN THE ARRAY YFFT1 AND YFFT2.
C     INTEGER M
C        THE NUMBER OF SERIES BEING COMPARED, IE THE
C        NUMBER OF COLUMNS OF DATA IN YM.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER NDUM(1)
C        A DUMMY ARRAY.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     REAL RHOC(201)
C        THE ARRAY CONTAINING THE CCF.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SDRHOC(201)
C        THE ARRAY CONTAINING THE SD OF THE CCF.
C     REAL STAK(12)
C        THE USED VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER WORK
C        THE STARTING LOCATION IN DSTAK FOR
C        THE WORK ARRAY NEEDED BY THE FFT.
C     REAL YFFT1(N), Y1MEAN, Y1SD
C        THE FIRST SERIES, AND ITS MEAN AND STANDARD DEVIATION.
C     REAL YFFT2(N), Y2MEAN, Y2SD
C        THE SECOND SERIES, AND ITS MEAN AND STANDARD DEVIATION.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'C',       'C',       'F',       'F',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      ICCOV = 101
      INLPPC = 1
      IYM = N
      JCCOV = 2
      JNLPPC = 1
      LAGMAX = 1
      IYMFFT = LYFFT
      M = 2
      NFFT = N
      ISFFT = .TRUE.
      ISLONG = .FALSE.
C
      IF (N.GE.3) THEN
C
C     SET LARGEST LAG VALUE TO BE USED
C
        CALL SETLAG(N, LAGMAX)
C
C     SET LENGTH OF THE EXTENDED SERIES
C
        CALL FFTLEN(N+LAGMAX, 4, NFFT)
      END IF
C
      CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN)
C
      CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV,
     +  INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET (LDSTAK, 4)
        NALL0 = STKST(1)
C
        IFP = 3
C
        WORK = STKGET(NFFT, IFP)
C
        IF (IERR.EQ.0) THEN
C
C         COMPUTE THE SERIES ACVF AND SD
C
          CALL ACVFF (YFFT1, N, NFFT, Y1MEAN, CCOV(1,1,1), LAGMAX, 101,
     +       LYFFT, STAK(WORK), NFFT)
          Y1SD = SQRT(CCOV(1,1,1) * N / (N-1))
C
          CALL ACVFF (YFFT2, N, NFFT, Y2MEAN, CCOV(1,2,2), LAGMAX, 101,
     +       LYFFT, STAK(WORK), NFFT)
          Y2SD = SQRT(CCOV(1,2,2) * N / (N-1))
C
C         CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
          IF (CCOV(1,1,1)*CCOV(1,2,2) .NE. 0.0E0)
     +       CALL CCFMNF (YFFT1, YFFT2, N, NFFT, LAGMAX, 2*LAGMAX+1,
     +       CCOV(1,1,1), CCOV(1,2,2), CCOV(1,1,2), CCOV(1,2,1), 101,
     +       RHOC, SDRHOC, 1, LYFFT, STAK(WORK), NFFT)
C
C         CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
          CALL CCFOUT (1, Y1MEAN, Y1SD, N, N, 2, Y2MEAN, Y2SD, N,
     +       N, LAGMAX, 2*LAGMAX+1, RHOC, SDRHOC, .FALSE., NDUM, NDUM,
     +       1, 0.0E0, 0.0E0, .FALSE.)
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL CCFF (YFFT1, YFFT2, N, LYFFT, LDSTAK)')
      END
*CCFFS
      SUBROUTINE CCFFS (YMFFT, N, M, IYMFFT, LAGMAX,
     +   CCOV, ICCOV, JCCOV, NPRT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS
C     CORRELATIONS AND COVARIANCES OF A MULTIVARIATE SERIES USING THE
C     SINGLETON FFT (LONG CALL).
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
     +   ICCOV,IYMFFT,JCCOV,LAGMAX,LDSTAK,M,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*),YMFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IFP,INLPPC,IO,IPRT,IYM,J,JNLPPC,K,LDSMIN,LYFFT,NALL0,
     +   NFFT,RHOC,SDRHOC,WORK,YMEAN,YMEANJ,YMEANK,YSD,YSDJ,YSDK
      LOGICAL
     +   ISFFT,ISLONG,NEWPG
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVFF,CCFER,CCFMNF,CCFOUT,FFTLEN,IPRINT,LDSCMP,STKCLR,
     +   STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  STATEMENT FUNCTIONS
      INTEGER
     +   I2,I3
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV(ICCOV, JCCOV, M)
C        THE CROSS COVARIANCE MATRIX.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ICCOV
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INLPPC
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC
C        IN THE USERS PROGRAM.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON WHETHER PRINTED OUTPUT IS DESIRED.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     LOGICAL ISLONG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE)
C     INTEGER IYM
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER IYMFFT
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER I2
C        STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN YMFFT
C     INTEGER I3
C        STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN CCOV
C     INTEGER J
C        THE INDEX OF -SERIES 1- IN THE ARRAY YMFFT.
C     INTEGER JCCOV
C        THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED
C        IN THE USERS PROGRAM.
C     INTEGER K
C        THE INDEX OF -SERIES 2- IN THE ARRAY YMFFT.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE NUMBER OF LOCATIONS IN EACH COLUMN OF YMFFT ALLOWED FOR
C        THE EXTENDED SERIES.
C     INTEGER M
C        THE NUMBER OF SERIES BEING COMPARED, IE THE
C        NUMBER OF COLUMNS OF DATA IN YMFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER NDUM(1)
C        A DUMMY DMENSIONED ARRAY.
C     LOGICAL NEWPG
C        AN INDICATOR VARIABLE USED TO DETERMINE WHEN A NEW PAGE
C        IS APPROPRIATE FOR THE OUTPUT.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPEDIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS GIVEN.
C     INTEGER RHOC
C        THE STARTING LOCATION IN STAK/DSTAK OF THE ARRAY RHOC.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHOC
C        THE STARTING LOCATION IN THE WORK AREA FOR SDRHOC.
C     INTEGER WORK
C        THE STARGING LOCATION IN DSTAK OF
C        THE WORK VECTOR NEEDED BY THE FFT.
C     INTEGER YMEAN, YMEANJ, YMEANK
C        THE STARTING LOCATION FOR THE ARRAY CONTAINING THE
C        MEANS OF EACH OF THE SERIES, AND THE LOCATION IN
C        THE ARRAY FOR THE MEAN OF THE JTH AND KTH SERIES,
C        RESPECTIVELY.
C     REAL YMFFT(IYMFFT, M)
C        THE MATRIX CONTAINING THE OBSERVED TIME SERIES
C     INTEGER YSD, YSDJ, YSDK
C        THE STARTING LOCATION FOR THE ARRAY CONTAINING THE
C        STANDARD DEVIATIONS OF EACH OF THE SERIES, AND THE
C        LOCATION IN THE ARRAY FOR THE STANDARD DEVIATION OF
C        THE JTH AND KTH SERIES, RESPECTIVELY.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'C',       'C',       'F',       'F',       'S',       ' '/
C
      I2(I,J) = I + (J-1)*IYMFFT
      I3(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      INLPPC = ICCOV
      IYM = IYMFFT
      JNLPPC = JCCOV
      LYFFT = IYMFFT
      M = 2
      ISFFT = .TRUE.
      ISLONG = .TRUE.
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
C
C     SET LENGTH OF EXTENDED SERIES
C
      IF ((N.GE.3) .AND. (LAGMAX.GE.1)) THEN
         CALL FFTLEN (N+LAGMAX, 4, NFFT)
      ELSE
         NFFT = N
      END IF
C
      CALL LDSCMP(3+2*IO, 0, 0, 0, 0, 0, 'S',
     +            2*M+NFFT+IO*(4*LAGMAX+2), LDSMIN)
C
      CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV,
     +  INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET (LDSTAK, 4)
        NALL0 = STKST(1)
C
        IFP = 3
C
        YMEAN = STKGET(M, IFP)
        YSD = STKGET(M, IFP)
        IF (NPRT.EQ.0) THEN
          RHOC = YSD
          SDRHOC = YSD
        ELSE
          RHOC = STKGET(2*LAGMAX+1, IFP)
          SDRHOC = STKGET(2*LAGMAX+1, IFP)
        END IF
        WORK = STKGET(NFFT, IFP)
C
        IF (IERR.EQ.0) THEN
C
C         BEGIN LOOP FOR COMPUTATIONS
C
          NEWPG = .FALSE.
C
          DO 40 K = 1, M
C
             YMEANK = YMEAN + K - 1
             YSDK = YSD + K - 1
C
             CALL ACVFF (YMFFT(I2(1,K)), N, NFFT, RSTAK(YMEANK),
     +                   CCOV(I3(1,K,K)), LAGMAX, ICCOV, LYFFT,
     +                   RSTAK(WORK), NFFT)
             RSTAK(YSDK) = SQRT(CCOV(I3(1,K,K)) * N / (N - 1))
C
             IF ((K-1).LE.0) GO TO 40
C
             DO 30 J = 1, (K-1)
C
                YMEANJ = YMEAN + J - 1
                YSDJ = YSD + J - 1
C
                CALL CCFMNF(YMFFT(I2(1,J)), YMFFT(I2(1,K)),
     +                      N, NFFT, LAGMAX, 2*LAGMAX+1,
     +                      CCOV(I3(1,J,J)), CCOV(I3(1,K,K)),
     +                      CCOV(I3(1,J,K)), CCOV(I3(1,K,J)),
     +                      ICCOV, RSTAK(RHOC), RSTAK(SDRHOC), NPRT,
     +                      LYFFT, RSTAK(WORK), NFFT)
C
                IF (NPRT .EQ. 0) GO TO 30
C
C         CALL ROUTINE TO PRINT OUT CORRELATIONS
C
                CALL CCFOUT (J, RSTAK(YMEANJ), RSTAK(YSDJ), N, N, K,
     +             RSTAK(YMEANK), RSTAK(YSDK), N, N, LAGMAX, 2*LAGMAX+1,
     +             RSTAK(RHOC), RSTAK(SDRHOC), .FALSE., NDUM, NDUM, 1,
     +             0.0E0, 0.0E0, NEWPG)
C
                NEWPG = .TRUE.
C
   30        CONTINUE
   40     CONTINUE
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL CCFFS (YMFFT, N, M, IYMFFT,'/
     + '      +            LAGMAX, CCOV, ICCOV, JCCOV, NPRT, LDSTAK)')
      END
*CCFLST
      SUBROUTINE CCFLST (RHOC, SDRHOC, NLPP12, NLPP21, LAGMAX, LCCOV,
     +   NCC, IFMISS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE ACTUALLY LISTS THE CROSS CORRELATIONS AND THEIR
C     STANDARD ERRORS, AND MISCELLANEOUS SUMMARY INFORMATION.
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
     +   LAGMAX,LCCOV,NCC
      LOGICAL
     +   IFMISS
C
C  ARRAY ARGUMENTS
      REAL
     +   RHOC(*),SDRHOC(*)
      INTEGER
     +   NLPP12(*),NLPP21(*)
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,I1,IMAX,IMIN,IPRT,K,K0,K1,LAGN,NPERL
C
C  LOCAL ARRAYS
      REAL
     +   RLST(12),SDRLST(12)
      INTEGER
     +   LAG(12),NLPLST(12)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     LOGICAL IFMISS
C        THE INDICATOR VARIABLE USED TO DETERMINE
C        WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT.
C     INTEGER IMAX, IMIN
C        THE INDEX VALUES OF THE FIRST AND LAST OBSERVATION
C        TO BE PRINTED PER LINE
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT
C     INTEGER I1
C        AN INDEX VARIABLE.
C     INTEGER K, K0, K1
C        INDEX VARIABLES.
C     INTEGER LAG(12)
C        THE LAG VALUE OF THE CORRELATION BEING PRINTED.
C     INTEGER LAGMAX
C        THE LARGEST LAG VALUE TO BE USED.
C     INTEGER LAGN
C        THE NUMBER OF LAG VALUES TO BE PRINTED PER LINE.
C     INTEGER LCCOV
C        THE NUMBER OF LOCATIONS ALLOWED FOR STORING THE NLPPC.
C     INTEGER NCC
C        THE NUMBER OF CROSS CORRELATIONS COMPUTED (FROM -LAGMAX
C        TO +LAGMAX).
C     INTEGER NLPLST(12)
C        THE ARRAY WHICH CONTAINS THE VALUES OF NLPPC TO BE PRINTED
C        ON EACH LINE, ORDERED PROPERLY.
C     INTEGER NLPP12(LCCOV), NLPP21(LCCOV)
C        THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE EACH
C        CCVF AT EACH LAG.
C     INTEGER NPERL
C        THE NUMBER OF VALUES TO BE PRINTED PER LINE.
C     REAL RHOC(NCC)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS OR PARTIAL
C        AUTOCORRELATIONS WILL BE PASSED TO THIS ROUTINE.
C     REAL RLST(12)
C        THE ARRAY WHICH CONTAINS THE VALUES OF RHO TO BE PRINTED
C        ON EACH LINE, ORDERED PROPERLY.
C     REAL SDRHOC(NCC)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C     REAL SDRLST(12)
C        THE ARRAY WHICH CONTAINS THE VALUES OF SDRHO TO BE PRINTED
C        ON EACH LINE, ORDERED PROPERLY.
C
C
      CALL IPRINT(IPRT)
      NPERL = 12
C
      K0 = LAGMAX + 1
C
      LAGN = MOD(LAGMAX, NPERL)
      IF (LAGN .EQ. 0) LAGN = NPERL
      I1 = LAGN + 1
C
      DO 20 I = I1, K0, NPERL
         DO 10 K = 1, LAGN
            LAG(K) = I - K0 - K
            K1 = I - K
            RLST(K) = RHOC(K1)
            SDRLST(K) = SDRHOC(K1)
            IF (.NOT. IFMISS) GO TO 10
            K1 = K0 - K1
            NLPLST(K) = NLPP21(K1+1)
   10    CONTINUE
         WRITE(IPRT, 1000) (LAG(K), K = 1, LAGN)
         WRITE(IPRT, 1001) (RLST(K), K = 1, LAGN)
         WRITE(IPRT, 1002) (SDRLST(K), K = 1, LAGN)
         IF (IFMISS) WRITE(IPRT, 1003) (NLPLST(K), K = 1, LAGN)
         LAGN = NPERL
   20 CONTINUE
C
      LAG(1) = 0
      WRITE(IPRT, 1000) LAG(1)
      WRITE(IPRT, 1001) RHOC(K0)
      WRITE(IPRT, 1002) SDRHOC(K0)
      IF (IFMISS) WRITE(IPRT, 1003) NLPP12(1)
C
      DO 40 I = 1, LAGMAX, NPERL
         IMIN = I + K0
         IMAX = MIN(IMIN + NPERL - 1, 2*LAGMAX+1)
         LAGN = IMAX - IMIN + 1
         DO 30 K = 1, LAGN
            LAG(K) = I - 1 + K
   30    CONTINUE
         WRITE(IPRT, 1000) (LAG(K), K = 1, LAGN)
         WRITE(IPRT, 1001) (RHOC(K), K = IMIN, IMAX)
         WRITE(IPRT, 1002) (SDRHOC(K), K = IMIN, IMAX)
         IF (.NOT. IFMISS) GO TO 40
         IMIN = I
         IMAX = MIN(I + NPERL - 1, LAGMAX)
         WRITE (IPRT,1003) (NLPP12(K+1), K=IMIN,IMAX)
   40 CONTINUE
C
      FPLM = R1MACH(2)
C
      IF (SDRHOC(1).EQ.FPLM .OR. SDRHOC(2*LAGMAX+1).EQ.FPLM)
     +   WRITE(IPRT, 1004) FPLM
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/19H LAG               , 12(1X, I6))
 1001 FORMAT( 19H CCF               , 12(2X, F5.2))
 1002 FORMAT( 19H STANDARD ERROR    , 12(2X, F5.2))
 1003 FORMAT( 19H NO. OF OBS. USED  , 12(1X, I6))
 1004 FORMAT(///5X, F5.2, 38H INDICATES VALUE COULD NOT BE COMPUTED,
     +   21H DUE TO MISSING DATA.)
      END
*CCFM
      SUBROUTINE CCFM (Y1, Y1MISS, Y2, Y2MISS, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS
C     CORRELATIONS OF TWO TIME SERIES WITH MISSING OBSERVATIONS
C     (SHORT CALL).
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
      REAL
     +   Y1MISS,Y2MISS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y1(*),Y2(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   Y1MEAN,Y1SD,Y2MEAN,Y2SD
      INTEGER
     +   ICCOV,INLPPC,IPRT,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX,LDSMIN,
     +   LDSTAK,LGLST1,LGLST2,LYFFT,M,NFFT,NUSED1,NUSED2
      LOGICAL
     +   ISFFT,ISLONG
C
C  LOCAL ARRAYS
      REAL
     +   CCOV(101,2,2),RHOC(201),SDRHOC(201)
      INTEGER
     +   NLPPC(101,2,2)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVFM,CCFER,CCFMNM,CCFOUT,IPRINT,SETLAG
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV(101, 2, 2)
C        THE ARRAY USED FOR THE CCVF ESTIMATES.
C     INTEGER ICCOV
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
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 INLPPC
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC
C        IN THE USERS PROGRAM.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     LOGICAL ISLONG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE)
C     INTEGER IYM
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER IYMFFT
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JCCOV
C        THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED
C        IN THE USERS PROGRAM.
C     INTEGER LAGMAX
C        THE NUMBER OF AUTOCORRELATIONS DESIRED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LGLST1, LGLST2
C        THE LAG VALUE OF THE LAST ACVF WHICH COULD BE COMPUTED
C        FOR SERIES 1 AND 2, RESPECTIVELY, BEFORE MISSING DATA
C        CAUSED A MISSING ACVF.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER M
C        THE NUMBER OF SERIES BEING COMPARED, IE THE
C        NUMBER OF COLUMNS OF DATA IN YM.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NLPPC(101, 2, 2)
C        THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE THE CCVF.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NUSED1, NUSED2
C        THE NUMBER OF ACTIVE (NON MISSING) OBSERVATIONS IN SERIES
C        1 AND 2, RESPECTIVELY.
C     REAL RHOC(201)
C        THE CCF ESTIMATES.
C     REAL SDRHOC(201)
C        THE ARRAY CONTAINING THE SD OF THE CCFM.
C     REAL Y1(N), Y1MEAN, Y1MISS, Y1SD
C        THE FIRST SERIES, AND ITS MEAN, MISSING VALUE CODE AND
C        STANDARD DEVIATION.
C     REAL Y2(N), Y2MEAN, Y2MISS, Y2SD
C        THE SECOND SERIES, AND ITS MEAN, MISSING VALUE CODE AND
C        STANDARD DEVIATION.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'C',       'C',       'F',       'M',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      ICCOV = 101
      INLPPC = 101
      IYM = N
      JCCOV = 2
      JNLPPC = 2
      LDSMIN = 0
      LDSTAK = 0
      LAGMAX = 1
      LYFFT = N + LAGMAX
      IYMFFT = LYFFT
      M = 2
      NFFT = N
      ISFFT = .FALSE.
      ISLONG = .FALSE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV,
     +  INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET THE MAXIMUM LAG VALUE TO BE USED.
C
        CALL SETLAG (N, LAGMAX)
C
C       COMPUTE THE SERIES ACVF AND SD
C
        CALL ACVFM (Y1, Y1MISS, N, Y1MEAN, CCOV(1,1,1), LAGMAX, LGLST1,
     +     NLPPC(1,1,1), 101)
C
        NUSED1 = NLPPC(1,1,1)
        Y1SD = SQRT(CCOV(1,1,1) * N / (NUSED1-1))
C
        CALL ACVFM (Y2, Y2MISS, N, Y2MEAN, CCOV(1,2,2), LAGMAX, LGLST2,
     +     NLPPC(1,2,2), 101)
C
        NUSED2 = NLPPC(1,2,2)
        Y2SD = SQRT(CCOV(1,2,2) * N / (NUSED2-1))
C
C       CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS.
C
        IF (CCOV(1,1,1)*CCOV(1,2,2) .NE. 0.0E0)
     +    CALL CCFMNM (Y1, Y1MISS, Y2, Y2MISS, N, LAGMAX, 201,
     +    CCOV(1,1,1),
     +    CCOV(1,2,2), CCOV(1,1,2), CCOV(1,2,1), 101, NLPPC(1,1,1),
     +    NLPPC(1,2,2), NLPPC(1,1,2), NLPPC(1,2,1), 101, Y1MEAN, Y2MEAN,
     +    RHOC, SDRHOC, 1, MIN(LGLST1, LGLST2))
C
C       CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS
C
        CALL CCFOUT (1, Y1MEAN, Y1SD, N, NUSED1, 2, Y2MEAN, Y2SD, N,
     +     NUSED2, LAGMAX, 201, RHOC, SDRHOC, .TRUE., NLPPC(1,1,2),
     +     NLPPC(1,2,1), 101, Y1MISS, Y2MISS, .FALSE.)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   44H       CALL CCFM (Y1, YMISS1, Y2, YMISS2, N))
      END
*CCFMN
      SUBROUTINE CCFMN (Y1, Y2, N, LAGMAX, NCC, CCOV11, CCOV22, CCOV12,
     +   CCOV21, LCCOV, Y1MEAN, Y2MEAN, RHOC, SDRHOC, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING CROSS CORRELATIONS AND
C     THEIR STANDARD ERRORS.
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
      REAL
     +   Y1MEAN,Y2MEAN
      INTEGER
     +   LAGMAX,LCCOV,N,NCC,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV11(LCCOV),CCOV12(LCCOV),CCOV21(LCCOV),CCOV22(LCCOV),
     +   RHOC(NCC),SDRHOC(NCC),Y1(N),Y2(N)
C
C  LOCAL SCALARS
      REAL
     +   FAC
      INTEGER
     +   I,I0,IM,IP
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CCFSD,CCVF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV11(LCCOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES
C        FOR THE FIRST SERIES IS STORED.
C     REAL CCOV12(LCCOV), CCOV21(LCCOV)
C        THE ARRAYS IN WHICH THE CROSS COVARIANCE FUNCTION
C        ESTIMATES FOR THE FIRST SERIES LAGGED BEHIND THE SECOND
C        AND VISA VERSA, ARE STORED.
C     REAL CCOV22(LCCOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES
C        FOR THE SECOND SERIES IS STORED.
C     REAL FAC
C        THE INVERSE OF THE SQUARE ROOT OF THE PRODUCT OF THE
C        AUTOCOVARIANCES AT LAG ZERO.
C     INTEGER I
C        THE INDEXING VARIABLE FOR THE LAG VALUE.
C     INTEGER  IM, IP, I0
C        THE LOCATIONS IN THE CCF RELATED ARRAYS
C        OF THE LAG -I, I, AND 0, RESPECTIVELY.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE AT WHICH THE CCVF IS TO BE COMPUTED.
C     INTEGER LCCOV
C        THE DIMENSION OF THE COVARIANCE RELATED ARRAYS.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NCC
C        THE NUMBER OF CCF COMPUTED.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO CONTROL COMPUTATIONS NEEDED
C        ONLY FOR PRINTED OUTPUT.
C     REAL RHOC(NCC)
C        THE ARRAY IN WHICH THE CROSS CORRELATIONS ARE STORED
C     REAL SDRHOC(NCC)
C        THE ARRAY CONTAINING THE STD. ERRORS OF THE CROSS CORRELATIONS.
C        ARE STORED
C     REAL Y1(N), Y1MEAN
C        THE FIRST SERIES, AND ITS MEAN.
C     REAL Y2(N), Y2MEAN
C        THE SECOND SERIES, AND ITS MEAN.
C
C     COMPUTE THE CROSS CORRELATIONS.
C
      CALL CCVF(Y1, Y2, N, LAGMAX, Y1MEAN, Y2MEAN, CCOV12, CCOV21,
     +   LCCOV)
C
      IF (NPRT .EQ. 0 .OR. CCOV11(1)*CCOV22(1) .EQ. 0.0E0) RETURN
C
      FAC = 1.0E0 / SQRT(CCOV11(1) * CCOV22(1))
C
      I0 = LAGMAX + 1
      RHOC(I0) = CCOV12(1) * FAC
      DO 10 I = 1, LAGMAX
         IP = I0 + I
         RHOC(IP) = CCOV12(I+1) * FAC
C
         IM = I0 - I
         RHOC(IM) = CCOV21(I+1) * FAC
   10 CONTINUE
C
C     COMPUTE STANDARD ERROR OF THE CROSSCORRELATIONS.
C
      CALL CCFSD (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, N, LCCOV)
C
      RETURN
      END
*CCFMNF
      SUBROUTINE CCFMNF (Y1, Y2, N, NFFT, LAGMAX, NCC, CCOV11, CCOV22,
     +   CCOV12, CCOV21, LCCOV, RHOC, SDRHOC, NPRT, LYFFT, WORK, LWORK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING CROSS CORRELATIONS AND
C     THEIR STANDARD ERRORS OF A TIME SERIES USING A FFT.
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
     +   LAGMAX,LCCOV,LWORK,LYFFT,N,NCC,NFFT,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV11(LCCOV),CCOV12(LCCOV),CCOV21(LCCOV),CCOV22(LCCOV),
     +   RHOC(NCC),SDRHOC(NCC),WORK(LWORK),Y1(LYFFT),Y2(LYFFT)
C
C  LOCAL SCALARS
      REAL
     +   FAC
      INTEGER
     +   I,I0,IM,IP
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CCFSD,CCVFF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV11(LCCOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES
C        FOR THE FIRST SERIES IS STORED.
C     REAL CCOV12(LCCOV), CCOV21(LCCOV)
C        THE ARRAYS IN WHICH THE CROSS COVARIANCE FUNCTION
C        ESTIMATES FOR THE FIRST SERIES LAGGED BEHIND THE SECOND
C        AND VISA VERSA, ARE STORED.
C     REAL CCOV22(LCCOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES
C        FOR THE SECOND SERIES IS STORED.
C     REAL FAC
C        THE INVERSE OF THE SQUARE ROOT OF THE PRODUCT OF THE
C        AUTOCOVARIANCES AT LAG ZERO.
C     INTEGER I
C        THE INDEXING VARIABLE FOR THE LAG VALUE.
C     INTEGER  IM, IP, I0
C        THE LOCATIONS IN THE CCF RELATED ARRAYS
C        OF THE LAG -I, I, AND 0, RESPECTIVELY.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LCCOV
C        THE DIMENSION OF THE COVARANCE ARRAYS.
C     INTEGER LWORK
C        THE DIMENSION OF THE WORK ARRAY.
C     INTEGER LYFFT
C        THE DIMENSION OF THE DATA ARRAYS.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NCC
C        THE NUMBER OF CROSS CORRELATIONS COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO CONTROL COMPUTATIONS NEEDED
C        ONLY FOR PRINTED OUTPUT.
C     REAL RHOC(NCC)
C        THE ARRAY IN WHICH THE CROSS CORRELATIONS ARE STORED
C     REAL SDRHOC(NCC)
C        THE ARRAY CONTAINING THE STD. ERRORS OF THE CROSS CORRELATIONS.
C        ARE STORED.
C     REAL WORK(LWORK)
C        THE WORK ARRAY.
C     REAL Y1(LYFFT), Y2(LYFFT)
C        THE VECTORS CONTAINING THE OBSERVED SERIES
C
C     COMPUTE THE CROSS CORRELATIONS.
C
      CALL CCVFF (Y1, Y2, N, NFFT, LAGMAX, CCOV12, CCOV21, LCCOV, LYFFT,
     +   WORK, LWORK)
C
      IF (NPRT .EQ. 0 .OR. CCOV11(1)*CCOV22(1) .EQ. 0.0E0) RETURN
C
      FAC = 1.0E0 / SQRT(CCOV11(1) * CCOV22(1))
C
      I0 = LAGMAX + 1
      RHOC(I0) = CCOV12(1) * FAC
      DO 10 I = 1, LAGMAX
         IP = I0 + I
         RHOC(IP) = CCOV12(I+1) * FAC
C
         IM = I0 - I
         RHOC(IM) = CCOV21(I+1) * FAC
   10 CONTINUE
C
C     COMPUTE STANDARD ERROR OF THE CROSSCORRELATIONS.
C
      CALL CCFSD (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, N, LCCOV)
C
      RETURN
      END
*CCFMNM
      SUBROUTINE CCFMNM (Y1, Y1MISS, Y2, Y2MISS, N, LAGMAX, NCC,
     +   CCOV11, CCOV22, CCOV12, CCOV21, ICCOV, NLPP11, NLPP22,
     +   NLPP12, NLPP21, INLPPC, Y1MEAN, Y2MEAN, RHOC, SDRHOC, NPRT,
     +   LAGLST)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING CROSS CORRELATIONS AND
C     THEIR STANDARD ERRORS WHEN MISSING DATA ARE INVOLVED.
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
      REAL
     +   Y1MEAN,Y1MISS,Y2MEAN,Y2MISS
      INTEGER
     +   ICCOV,INLPPC,LAGLST,LAGMAX,N,NCC,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV11(ICCOV),CCOV12(ICCOV),CCOV21(ICCOV),CCOV22(ICCOV),
     +   RHOC(NCC),SDRHOC(NCC),Y1(N),Y2(N)
      INTEGER
     +   NLPP11(INLPPC),NLPP12(INLPPC),NLPP21(INLPPC),
     +   NLPP22(INLPPC)
C
C  LOCAL SCALARS
      REAL
     +   FAC,FPLM
      INTEGER
     +   I,I0,IM,IP
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CCFSDM,CCVFM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV11(ICCOV), CCOV12(ICCOV)
C     REAL CCOV21(ICCOV), CCOV22(ICCOV)
C        THE ARRAY CONTAINING THE AUTOCOVARIANCE AND CROSS COVARIANCE
C        ESTIMATES FOR SERIES 1 AND 2.
C     REAL FAC
C        THE INVERSE OF THE SQUARE ROOT OF THE PRODUCT OF THE
C        AUTOCOVARIANCES AT LAG ZERO.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        THE INDEXING VARIABLE FOR THE LAG.
C     INTEGER ICCOV
C        THE DIMENSION OF THE COVARIANCE VECTORS.
C     INTEGER IM
C        THE LOCATIONS IN THE VARIOUS CCF RELATED ARRAYS OF LAG -I.
C     INTEGER INLPPC
C        THE DIMENSION OF THE LAGGED PRODUCT PAIR COUNT VECTORS.
C     INTEGER IP
C        THE LOCATION IF THE VARIOUS CCF RELATED ARRAYS OF LAG I.
C     INTEGER I0
C        THE LOCATION IF THE VARIOUS CCF RELATED ARRAYS OF LAG 0.
C     INTEGER LAGLST
C        THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF EITHER
C        SERIES 1 OR 2 NOT TO BE COMPUTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NCC
C        THE NUMBER OF CROSS CORRELATIONS TO BE COMPUTED.
C     INTEGER NLPP11(INLPPC), NLPP12(INLPPC), NLPP21(INLPPC),
C    +        NLPP22(INLPPC)
C        THE NUMBERS OF LAGGED PRODUCT PAIRS USED TO COMPUTE
C        THE AUTOCOVARIANCE AND CROSS COVARIANCE ESTIMATES.
C     INTEGER NPRT
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT.
C     REAL RHOC(NCC)
C        THE ARRAY IN WHICH THE AUTO AND CROSS CORRELATIONS ARE STORED
C     REAL SDRHOC(NCC)
C        THE ARRAY CONTAINING THE STD. ERRORS OF THE CROSS CORRELATIONS.
C        ARE STORED
C     REAL Y1(N), Y1MEAN, Y1MISS
C        THE FIRST SERIES, AND ITS MEAN, AND MISSING VALUE CODE.
C     REAL Y2(N), Y2MEAN, Y2MISS
C        THE SECOND SERIES, AND ITS MEAN, AND MISSING VALUE CODE.
C
      FPLM = R1MACH(2)
C
C     COMPUTE AUTOCORRELATIONS AND STANDARD DEVIATION OF THE SERIES.
C
      CALL CCVFM(Y1, Y1MISS, Y2, Y2MISS, N, LAGMAX, Y1MEAN, Y2MEAN,
     +   CCOV12, CCOV21, ICCOV, NLPP12, NLPP21)
C
      IF (NPRT .EQ. 0 .OR. NLPP11(1) .EQ. 0) RETURN
      IF (CCOV11(1) *CCOV22(1) .EQ. 0.0E0) RETURN
C
      FAC = 1.0E0 / SQRT(CCOV11(1) * CCOV22(1))
C
      I0 = LAGMAX + 1
      RHOC(I0) = FPLM
      IF (NLPP12(1).GE.1) RHOC(I0) = CCOV12(1) * FAC
C
      DO 10 I = 1, LAGMAX
         IP = I0 + I
         RHOC(IP) = FPLM
         IF (NLPP12(I+1).GE.1) RHOC(IP) = CCOV12(I+1) * FAC
C
         IM = I0 - I
         RHOC(IM) = FPLM
         IF (NLPP21(I+1).GE.1) RHOC(IM) = CCOV21(I+1) * FAC
   10 CONTINUE
C
C     COMPUTE STANDARD ERROR OF AUTOCORRELATIONS.
C
      CALL CCFSDM (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, LAGLST, N,
     +   NLPP12, NLPP21, ICCOV, INLPPC)
C
      RETURN
      END
*CCFMS
      SUBROUTINE CCFMS (YM, YMMISS, N, M, IYM, LAGMAX, CCOV,
     +   CMISS, ICCOV, JCCOV, NLPPC, INLPPC, JNLPPC, NPRT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS
C     CORRELATIONS AND COVARIANCES OF A MULTIVARIATE SERIES (LONG CALL).
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
      REAL
     +   CMISS
      INTEGER
     +   ICCOV,INLPPC,IYM,JCCOV,JNLPPC,LAGMAX,LDSTAK,M,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*),YM(*),YMMISS(*)
      INTEGER
     +   NLPPC(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,IFP,IO,IPRT,IYMFFT,J,K,LDSMIN,LGLST,LGLSTJ,LGLSTK,LYFFT,
     +   NALL0,NFFT,RHOC,SDRHOC,YMEAN,YMEANJ,YMEANK,YSD,YSDJ,YSDK
      LOGICAL
     +   ISFFT,ISLONG,NEWPG
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      INTEGER
     +   STKGET,STKST
      EXTERNAL R1MACH,STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVFM,CCFER,CCFMNM,CCFOUT,IPRINT,LDSCMP,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  STATEMENT FUNCTIONS
      INTEGER
     +   I2,I3C,I3N
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV(ICCOV, JCCOV, M)
C        THE CROSS COVARIANCE MATRIX.
C     REAL CMISS
C        THE MISSING VALUE CODE FOR THE CCVF ESTIMATES.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER ICCOV
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INLPPC
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC
C        IN THE USERS PROGRAM.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON WHETHER PRINTED OUTPUT IS DESIRED.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     LOGICAL ISLONG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE)
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IYM
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER IYMFFT
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER I2
C        STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN YM
C     INTEGER I3C
C        STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN CCOV
C     INTEGER I3N
C        STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN NLPPC
C     INTEGER J
C        THE INDEX OF -SERIES 1- IN THE ARRAY YM.
C     INTEGER JCCOV
C        THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED
C        IN THE USERS PROGRAM.
C     INTEGER K
C        THE INDEX OF -SERIES 2- IN THE ARRAY YM.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LGLST, LGLSTJ, LGLSTK
C        THE STARTING LOCATION IN ISTAK FOR THE ARRAY LGLST,
C        AND THE LOCATIONS IN LGLST IN EHICH THE NUMBER OF THE
C        LAG OF THE LAST ACVF WHICH COULD BE COMPUTED FOR SERIES
C        J AND K, RESPECTIVELY, BEFORE A MISSNG ACVF (DUE TO MISSING
C        DATA).
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER M
C        THE NUMBER OF SERIES BEING COMPARED, IE THE
C        NUMBER OF COLUMNS OF DATA IN YM.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     LOGICAL NEWPG
C        AN INDICATOR VARIABLE USED TO DETERMINE WHEN A NEW PAGE
C        IS APPROPRIATE FOR THE OUTPUT.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NLPPC(INLPPC, JNLPPC, M)
C        THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS
C        USED TO COMPUTE EACH ACVF ESTIMATE.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPEDIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS GIVEN.
C     INTEGER RHOC
C        THE STARTING LOCATION IN DSTAK OF THE ARRAY RHOC.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHOC
C        THE STARTING LOCATION IN THE WORK AREA FOR SDRHOC.
C     REAL YM(IYM, M)
C        THE MATRIX CONTAINING THE OBSERVED TIME SERIES
C     INTEGER YMEAN, YMEANJ, YMEANK
C        THE STARTING LOCATION FOR THE ARRAY CONTAINING THE
C        MEANS OF EACH OF THE SERIES, AND THE LOCATION IN
C        THE ARRAY FOR THE MEAN OF THE JTH AND KTH SERIES,
C        RESPECTIVELY.
C     REAL YMMISS(M)
C        THE MISSING VALUE CODES FOR EACH OF THE SERIES IN YM.
C     INTEGER YSD, YSDJ, YSDK
C        THE STARTING LOCATION FOR THE ARRAY CONTAINING THE
C        STANDARD DEVIATIONS OF EACH OF THE SERIES, AND THE
C        LOCATION IN THE ARRAY FOR THE STANDARD DEVIATION OF
C        THE JTH AND KTH SERIES, RESPECTIVELY.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'C',       'C',       'F',       'M',       'S',       ' '/
C
      I2(I,J) = I + (J-1)*IYM
      I3C(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV
      I3N(I,J,K) = I + (J-1)*INLPPC + (K-1)*JNLPPC*INLPPC
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      LYFFT = N + LAGMAX
      IYMFFT = LYFFT
      NFFT = N
      ISFFT = .FALSE.
      ISLONG = .TRUE.
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
C
      CALL LDSCMP(3+2*IO, 0, M, 0, 0, 0, 'S',
     +            2*M+IO*(4*LAGMAX+2), LDSMIN)
C
      CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV,
     +  INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
        FPLM = R1MACH(2)
C
C       SET UP THE WORK AREA.
C
        CALL STKSET (LDSTAK, 4)
        NALL0 = STKST(1)

        IFP = 3
C
        YMEAN = STKGET(M, IFP)
        YSD = STKGET(M, IFP)
        LGLST = STKGET(M, 2)
        IF (NPRT.EQ.0) THEN
          RHOC = YSD
          SDRHOC = YSD
        ELSE
          RHOC = STKGET(2*LAGMAX+1, IFP)
          SDRHOC = STKGET(2*LAGMAX+1, IFP)
        END IF
C
        IF (IERR.EQ.0) THEN
C
C         BEGIN LOOP FOR COMPUTATIONS
C
          NEWPG = .FALSE.
C
          DO 40 K = 1, M
C
             YMEANK = YMEAN + K - 1
             YSDK = YSD + K - 1
             LGLSTK = LGLST + K - 1
C
             CALL ACVFM (YM(I2(1,K)), YMMISS(K), N, RSTAK(YMEANK),
     +                   CCOV(I3C(1,K,K)), LAGMAX, ISTAK(LGLSTK),
     +                   NLPPC(I3N(1,K,K)), LAGMAX+1)
             RSTAK(YSDK) = SQRT(CCOV(I3C(1,K,K)) * N / (N - 1))
C
             IF ((K-1).LE.0) GO TO 40
C
             DO 30 J = 1, (K-1)
C
                YMEANJ = YMEAN + J - 1
                YSDJ = YSD + J - 1
                LGLSTJ = LGLST + J - 1
C
                CALL CCFMNM (YM(I2(1,J)), YMMISS(J),
     +                       YM(I2(1,K)), YMMISS(K),
     +                       N,  LAGMAX, 2*LAGMAX+1,
     +                       CCOV(I3C(1,J,J)), CCOV(I3C(1,K,K)),
     +                       CCOV(I3C(1,J,K)), CCOV(I3C(1,K,J)), ICCOV,
     +                       NLPPC(I3N(1,J,J)), NLPPC(I3N(1,K,K)),
     +                       NLPPC(I3N(1,J,K)), NLPPC(I3N(1,K,J)),
     +                       INLPPC,
     +                       RSTAK(YMEANJ), RSTAK(YMEANK), RSTAK(RHOC),
     +                       RSTAK(SDRHOC),
     +                       NPRT, MIN(ISTAK(LGLSTJ), ISTAK(LGLSTK)))
C
                IF (NPRT .EQ. 0) GO TO 30
C
C         CALL ROUTINE TO PRINT OUT CORRELATIONS
C
                CALL CCFOUT (J, RSTAK(YMEANJ), RSTAK(YSDJ), N,
     +                       NLPPC(I3N(1,J,J)), K, RSTAK(YMEANK),
     +                       RSTAK(YSDK), N, NLPPC(I3N(1,K,K)), LAGMAX,
     +                       2*LAGMAX+1, RSTAK(RHOC), RSTAK(SDRHOC),
     +                       .TRUE., NLPPC(I3N(1,J,K)),
     +                       NLPPC(I3N(1,K,J)),
     +                       INLPPC, YMMISS(J), YMMISS(K), NEWPG)
C
                NEWPG = .TRUE.
C
   30        CONTINUE
   40     CONTINUE
C
          CMISS = FPLM
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL CCFMS (YM, YMMISS, N, M, IYM,'/
     +  '      +            LAGMAX, CCOV, CMISS, ICCOV, JCCOV,'/
     +  '      +            NLPPC, INLPPC, JNLPPC, NPRT, LDSTAK)')
      END
*CCFOUT
      SUBROUTINE CCFOUT (J, YMEANJ, YSDJ, NJ, NUSEDJ, K, YMEANK, YSDK,
     +   NK, NUSEDK, LAGMAX, NCC, RHOC, SDRHOC, IFMISS, NLPP12,
     +   NLPP21, LCCOV, YMISSJ, YMISSK, NEWPG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE CROSS CORRELATIONS AND THEIR
C     STANDARD ERRORS, AND MISCELLANEOUS SUMMARY INFORMATION.
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
      REAL
     +   YMEANJ,YMEANK,YMISSJ,YMISSK,YSDJ,YSDK
      INTEGER
     +   J,K,LAGMAX,LCCOV,NCC,NJ,NK,NUSEDJ,NUSEDK
      LOGICAL
     +   IFMISS,NEWPG
C
C  ARRAY ARGUMENTS
      REAL
     +   RHOC(*),SDRHOC(*)
      INTEGER
     +   NLPP12(*),NLPP21(*)
C
C  LOCAL SCALARS
      REAL
     +   FPLM,PMISSJ,PMISSK
      INTEGER
     +   IPRT,NMISSJ,NMISSK
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CCFLST,IPRINT,VERSP,VPMN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC REAL
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     LOGICAL IFMISS
C        THE INDICATOR VARIABLE USED TO DETERMINE
C        WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT.
C     INTEGER IPRT
C        THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED
C        OUTPUT.
C     INTEGER ISYM(1)
C        A DUMMY ARRAY.
C     INTEGER J, K
C        THE SUBSCRIPT VALUES OF THE TWO SERIES BEING COMPARED.
C     INTEGER LAGMAX
C        THE LARGEST LAG VALUE TO BE USED.
C     INTEGER LCCOV
C        THE NUMBER OF LOCATIONS ALLOWED FOR STORING THE NLPPC.
C     INTEGER NCC
C        THE NUMBER OF CROSS CORRELATIONS COMPUTED (FROM -LAGMAX
C        TO +LAGMAX).
C     LOGICAL NEWPG
C        AN INDICATOR VARIABLE USED TO DETERMINE IF THE OUTPUT SHOULD
C        START ON A NEW PAGE.
C     INTEGER NJ, NK
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NLPP12(LCCOV), NLPP21(LCCOV)
C        THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE EACH
C        CCVF AT EACH LAG.
C     INTEGER NMISSJ, NMISSK
C        THE NUMBER OF MISSING VALUES IN EACH SERIES.
C     INTEGER NUSEDJ, NUSEDK
C        THE ACTIVE NUMBER OF OBSERVATIONS IN EACH SERIES.
C     REAL PMISSJ, PMISSK
C        THE PERCENT OF MISSING OBSERVATIONS.
C     REAL RHOC(NCC)
C        THE ARRAY IN WHICH THE CROSS CORRELATIONS ARE STORED
C     REAL SDRHOC(NCC)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS
C        ARE STORED
C     REAL YMEANJ, YMEANK
C        THE MEAN OF EACH OF THE SERIES.
C     REAL YMISSJ, YMISSK
C        THE MISSING VALUE CODE FOR EACH SERIES.
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE CROSS CORRELATIONS.
C     REAL YSDJ, YSDK
C        THE STANDARD DEVIAION OF EACH SERIES.
C
      FPLM = R1MACH(2)
C
      YMMISS(1) = FPLM
C
C     PRINT SUMMARY INFORMATION
C
      CALL IPRINT(IPRT)
C
      IF (NEWPG) WRITE (IPRT, 1004)
      CALL VERSP (.TRUE.)
      WRITE(IPRT, 1005)
C
      WRITE(IPRT, 1000) J, K, YMEANJ, YMEANK, YSDJ, YSDK, NJ, NK
      IF (.NOT. IFMISS) GO TO 10
      NMISSJ = NJ - NUSEDJ
      PMISSJ = 100.0E0 * NMISSJ / NJ
      NMISSK = NK - NUSEDK
      PMISSK = 100.0E0 * NMISSK / NK
      WRITE(IPRT, 1003) NMISSJ, NMISSK, PMISSJ, PMISSK
C
   10 WRITE(IPRT, 1006) LAGMAX
      IF (IFMISS) WRITE(IPRT, 1007) YMISSJ, YMISSK
C
      IF (YSDJ .GT. 0.0E0 .AND. YSDK .GT. 0.0E0) GO TO 20
      WRITE (IPRT, 1008) J, K
      RETURN
C
C     PRINT CCF INFORMATION
C
   20 CONTINUE
      WRITE(IPRT, 1002)
      WRITE (IPRT, 1001) J, K
      CALL CCFLST (RHOC, SDRHOC, NLPP12, NLPP21, LAGMAX, LCCOV, NCC,
     +   IFMISS)
C
C     PLOT CCF INFORMATION
C
      WRITE(IPRT, 1004)
      CALL VERSP (.TRUE.)
      WRITE (IPRT, 1001) J, K
      CALL VPMN(RHOC, YMMISS, 2*LAGMAX+1, 1, 2*LAGMAX+1, 1, 0,
     +   ISYM, 1, 0, -1.0E0, 1.0E0, REAL(-LAGMAX), 1.0E0, IFMISS,
     +   0, 0, 1)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/ 42X, 7HSERIES , I2, 5X, 7HSERIES , I2//
     +   41H AVERAGE OF THE SERIES                 = , 2G14.7/
     +   41H STANDARD DEVIATION OF THE SERIES      = , 2G14.7/
     +   41H NUMBER OF TIME POINTS                 = , 2(I10, 4X))
 1001 FORMAT (42H CROSS CORRELATION FUNCTION ESTIMATE (CCF)//
     +   22H CCF CORRELATES SERIES , I2, 22H AT TIME T WITH SERIES , I2,
     +   15H AT TIME T + K./
     +   5X, 55H(IF PEAK CORRELATION OCCURES AT POSITIVE (NEGATIVE) LAG/
     +   8X, 36HTHEN SERIES 1 LEADS (LAGS) SERIES 2))
 1002 FORMAT(//)
 1003 FORMAT (
     +   41H NUMBER OF MISSING OBSERVATIONS        = , 2(I10, 4X)/
     +   41H PERCENTAGE OF OBSERVATIONS MISSING    = , 2(F10.4, 4X))
 1004 FORMAT ('1')
 1005 FORMAT ( 27H CROSS CORRELATION ANALYSIS)
 1006 FORMAT(/
     +   41H LARGEST LAG VALUE TO BE USED          = , I10)
 1007 FORMAT(
     +   41H MISSING VALUE CODE                    = , 2G14.7)
 1008 FORMAT (//35H CROSS CORRELATIONS BETWEEN SERIES , I2, 5H AND ,
     +   I2, 22H COULD NOT BE COMPUTED/
     +   54H BECAUSE THE LAG ZERO AUTOCOVARIANCE OF ONE OR BOTH OF/
     +   20H THE SERIES IS ZERO.)
      END
*CCFSD
      SUBROUTINE CCFSD (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, N, ICCOV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING THE STANDARD ERROR
C     OF THE CROSS CORRELATIONS.
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
     +   ICCOV,LAGMAX,N,NCC
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV11(ICCOV),CCOV22(ICCOV),SDRHOC(NCC)
C
C  LOCAL SCALARS
      REAL
     +   DIV,SUM
      INTEGER
     +   I,ILAST,K,K0,KM,KP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV11(ICCOV), CCOV22(ICCOV)
C        THE ARRAYS IN WHICH THE AUTOCOVARIANCES ARE STORED
C     REAL DIV
C        THE SQUARE ROOT OF THE PRODUCT OF THE AUTOCOVARIANCE
C        FUNCTION VALUES AT LAG ZERO.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER ICCOV
C        THE DIMENSION OF THE ACVF ARRAYS.
C     INTEGER ILAST
C        THE LAST LAG AT WHICH THE STANDARD ERROR IS TO BE COMPUTED.
C     INTEGER K
C        AN INDEX VARIALBE.
C     INTEGER KM, KP, K0
C        THE LOCATIONS IN THE ARRAYS -RHOC- AND -SDRHOC-
C        OF THE LAG -K, K AND 0, RESPECTIVELY.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE USED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NCC
C        THE NUMBER OF CCF COMPUTED.
C     REAL SDRHOC(NCC)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE CROSS CORRELATION
C        ARE STORED
C     REAL SUM
C         A SUMMING VARIABLE.
C
      K0 = LAGMAX + 1
C
      DIV = CCOV11(1) * CCOV22(1)
C
      SUM = 0.0E0
      DO 10 I = 1, LAGMAX
         SUM = SUM + CCOV11(I+1) * CCOV22(I+1)
   10 CONTINUE
      SUM = SUM / DIV
      SDRHOC(K0) = SQRT(N + 2.0E0 * SUM) / N
C
      DO 30 K = 1, LAGMAX
         SUM = 0.0E0
         ILAST = MIN(LAGMAX, N-LAGMAX)
         DO 20 I = 1, ILAST
            SUM = SUM + (N-K-I)*CCOV11(I+1)*CCOV22(I+1)
   20    CONTINUE
         SUM = SUM / DIV
         KM = K0 - K
         SDRHOC(KM) = SQRT((N - K) + 2.0E0 * SUM) / N
C
         KP = K0 + K
         SDRHOC(KP) = SDRHOC(KM)
C
   30 CONTINUE
C
      RETURN
      END
*CCFSDM
      SUBROUTINE CCFSDM (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, LAGLST, N,
     +   NLPP12, NLPP21, ICCOV, INLPPC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING THE STANDARD ERROR
C     OF THE CROSS CORRELATIONS WHEN THERE ARE MISSING VALUES.
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
     +   ICCOV,INLPPC,LAGLST,LAGMAX,N,NCC
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV11(ICCOV),CCOV22(ICCOV),SDRHOC(NCC)
      INTEGER
     +   NLPP12(INLPPC),NLPP21(INLPPC)
C
C  LOCAL SCALARS
      REAL
     +   DIV,FPLM,SUM
      INTEGER
     +   I,ILAST,K,K0,KM,KP
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV11(ICCOV), CCOV22(ICCOV)
C        THE ARRAYS IN WHICH THE AUTOCOVARIANCES ARE STORED.
C     REAL DIV
C        THE SQUARE ROOT OF THE PRODUCT OF THE AUTOCOVARIANCE
C        FUNCTION VALUES AT LAG ZERO.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        INDEXING VARIABLES.
C     INTEGER ICCOV
C        THE DIMENSION OF THE COVARIANCE VECTORS.
C     INTEGER ILAST
C        THE LAST LAG AT WHICH THE STANDARD ERRORS ARE TO BE COMPUTED.
C     INTEGER INLPPC
C        THE DIMENSION OF THE LAGGED PRODUCT PAIR COUNT VECTORS.
C     INTEGER K
C        INDEXING VARIABLES.
C     INTEGER KM, KP, K0
C        THE LOCATIONS IN THE ARRAYS -RHOC- AND -SDRHOC-
C        OF THE LAG -K, K AND 0, RESPECTIVELY.
C     INTEGER LAGLST
C        THE LAST AUTOCORRELATION COMPUTED BEFORE A MISSING
C        AUTOCORRELATION WAS INCOUNTERED IN EITHER SERIES.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE USED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NCC
C       THE NUMBER OF CROSS CORRELATIONS COMPUTED.
C     INTEGER NLPP12(INLPPC), NLPP21(INLPPC)
C        THE ARRAYS IN WHICH THE NUMBER OF OBSERVATIONS USED TO
C        COMPUTE EACH CROSS CORRELATION ARE STORED.
C     REAL SDRHOC(NCC)
C        THE ARRAY IN WHICH THE STANDARD ERRORS OF THE CROSS CORRELATION
C        ARE STORED
C     REAL SUM
C         A SUMMING VARIABLE.
C
      FPLM = R1MACH(2)
C
      DIV = CCOV11(1) * CCOV22(1)
C
      K0 = LAGMAX + 1
C
      SUM = 0.0E0
      DO 10 I = 1, LAGLST
         SUM = SUM + CCOV11(I+1) * CCOV22(I+1)
   10 CONTINUE
      SUM = SUM / DIV
      SDRHOC(K0) = FPLM
      IF (NLPP12(1) .GE. 1) SDRHOC(K0) =
     +   SQRT(N + 2.0E0 * SUM) / NLPP12(1)
C
      DO 30 K = 1, LAGMAX
         SUM = 0.0E0
         ILAST = MIN(LAGLST, N-LAGLST)
         DO 20 I = 1, ILAST
            SUM = SUM + (N-K-I) * CCOV11(I+1) * CCOV22(I+1)
   20    CONTINUE
         SUM = SUM / DIV
         KM = K0 - K
         SDRHOC(KM) = FPLM
         IF (NLPP21(K+1) .GE. 1) SDRHOC(KM) =
     +      SQRT((N - K) + 2.0E0 * SUM) * (N - K)/ (N * NLPP21(K+1))
C
         KP = K0 + K
         SDRHOC(KP) = FPLM
         IF (NLPP12(K+1) .GE. 1) SDRHOC(KP) =
     +      SQRT((N - K) + 2.0E0 * SUM) * (N - K) / (N * NLPP12(K+1))
   30 CONTINUE
C
      RETURN
      END
*CCFS
      SUBROUTINE CCFS (YM, N, M, IYM, LAGMAX, CCOV, ICCOV, JCCOV,
     +   NPRT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS
C     CORRELATIONS AND COVARIANCES OF A MULTIVARIATE SERIES (LONG CALL).
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
     +   ICCOV,IYM,JCCOV,LAGMAX,LDSTAK,M,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IFP,INLPPC,IO,IPRT,IYMFFT,J,JNLPPC,K,LDSMIN,LYFFT,NALL0,
     +   NFFT,RHOC,SDRHOC,YMEAN,YMEANJ,YMEANK,YSD,YSDJ,YSDK
      LOGICAL
     +   ISFFT,ISLONG,NEWPG
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   NDUM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVF,CCFER,CCFMN,CCFOUT,IPRINT,LDSCMP,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  STATEMENT FUNCTIONS
      INTEGER
     +   I2,I3
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV(ICCOV, JCCOV, M)
C        THE CROSS COVARIANCE MATRIX.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ICCOV
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER INLPPC
C        THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC
C        IN THE USERS PROGRAM.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON WHETHER PRINTED OUTPUT IS DESIRED.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     LOGICAL ISFFT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE)
C     LOGICAL ISLONG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE)
C     INTEGER IYM
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER IYMFFT
C        THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER I2
C        STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN YM
C     INTEGER I3
C        STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN CCOV
C     INTEGER J
C        THE INDEX OF -SERIES 1- IN THE ARRAY YM.
C     INTEGER JCCOV
C        THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS
C        SPECIFIED IN THE USERS PROGRAM.
C     INTEGER JNLPPC
C        THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED
C        IN THE USERS PROGRAM.
C     INTEGER K
C        THE INDEX OF -SERIES 2- IN THE ARRAY YM.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER M
C        THE NUMBER OF SERIES BEING COMPARED, IE THE
C        NUMBER OF COLUMNS OF DATA IN YM.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER NDUM(1)
C        A DUMMY DIMENSIONED VARIABLE.
C     LOGICAL NEWPG
C        AN INDICATOR VARIABLE USED TO DETERMINE WHEN A NEW PAGE
C        IS APPROPRIATE FOR THE OUTPUT.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPEDIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO OUTPUT IS GIVEN.
C     INTEGER RHOC
C        THE STARTING LOCATION IN DSTAK OF THE ARRAY RHOC.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER SDRHOC
C        THE STARTING LOCATION IN THE WORK AREA FOR SDRHOC.
C     REAL YM(IYM, M)
C        THE MATRIX CONTAINING THE OBSERVED TIME SERIES
C     INTEGER YMEAN, YMEANJ, YMEANK
C        THE STARTING LOCATION FOR THE ARRAY CONTAINING THE
C        MEANS OF EACH OF THE SERIES, AND THE LOCATION IN
C        THE ARRAY FOR THE MEAN OF THE JTH AND KTH SERIES,
C        RESPECTIVELY.
C     INTEGER YSD, YSDJ, YSDK
C        THE STARTING LOCATION FOR THE ARRAY CONTAINING THE
C        STANDARD DEVIATIONS OF EACH OF THE SERIES, AND THE
C        LOCATION IN THE ARRAY FOR THE STANDARD DEVIATION OF
C        THE JTH AND KTH SERIES, RESPECTIVELY.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'C',       'C',       'F',       'S',       ' ',       ' '/
C
      I2(I,J) = I + (J-1)*IYM
      I3(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      INLPPC = ICCOV
      JNLPPC = JCCOV
      LYFFT = N + LAGMAX
      IYMFFT = IYM
      NFFT = N
      ISFFT = .FALSE.
      ISLONG = .TRUE.
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
C
      CALL LDSCMP(2+2*IO, 0, 0, 0, 0, 0, 'S',
     +            2*M+IO*(4*LAGMAX+2), LDSMIN)
C
      CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV,
     +  INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG)
C
C     CHECK WHETHER AN ERROR HAS BEEN DETECTED
C
      IF (IERR.EQ.0) THEN
C
C       SET UP THE WORK AREA.
C
        CALL STKSET (LDSTAK, 4)
        NALL0 = STKST(1)
C
        IFP = 3
C
        YMEAN = STKGET(M, IFP)
        YSD = STKGET(M, IFP)
        IF (NPRT.EQ.0) THEN
          RHOC = YSD
          SDRHOC = YSD
        ELSE
          RHOC = STKGET(2*LAGMAX+1, IFP)
          SDRHOC = STKGET(2*LAGMAX+1, IFP)
        END IF
C
        IF (IERR.EQ.0) THEN
C
C         BEGIN LOOP FOR COMPUTATIONS
C
          NEWPG = .FALSE.
C
          DO 40 K = 1, M
C
             YMEANK = YMEAN + K - 1
             YSDK = YSD + K - 1
C
             CALL ACVF (YM(I2(1,K)), N, RSTAK(YMEANK),
     +                  CCOV(I3(1,K,K)), LAGMAX, ICCOV)
             RSTAK(YSDK) = SQRT(CCOV(I3(1,K,K)) * N / (N - 1))
C
             IF ((K-1).LE.0) GO TO 40
C
             DO 30 J = 1, (K-1)
C
                YMEANJ = YMEAN + J - 1
                YSDJ = YSD + J - 1
C
                CALL CCFMN (YM(I2(1,J)), YM(I2(1,K)),
     +                      N, LAGMAX, 2*LAGMAX+1,
     +                      CCOV(I3(1,J,J)), CCOV(I3(1,K,K)),
     +                      CCOV(I3(1,J,K)), CCOV(I3(1,K,J)),
     +                      ICCOV, RSTAK(YMEANJ), RSTAK(YMEANK),
     +                      RSTAK(RHOC), RSTAK(SDRHOC), NPRT)
C
                IF (NPRT .EQ. 0) GO TO 30
C
C         CALL ROUTINE TO PRINT OUT CORRELATIONS
C
                CALL CCFOUT (J, RSTAK(YMEANJ), RSTAK(YSDJ), N, N, K,
     +             RSTAK(YMEANK), RSTAK(YSDK), N, N, LAGMAX, 2*LAGMAX+1,
     +             RSTAK(RHOC), RSTAK(SDRHOC), .FALSE., NDUM, NDUM, 1,
     +             0.0E0, 0.0E0, NEWPG)
C
                NEWPG = .TRUE.
C
   30        CONTINUE
   40     CONTINUE
        END IF
C
        CALL STKCLR(NALL0)
      END IF
C
      IF (IERR.NE.0) THEN
C
C     PRINT PROPER CALL SEQUENCE AND RETURN
C
        IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL CCFS (YM, N, M, IYM,'/
     +   '      +           LAGMAX, CCOV, ICCOV, JCCOV, NPRT, LDSTAK)')
      END
*CCFXP
      SUBROUTINE CCFXP (STORE, LAGMAX, M, CCOV, ICCOV, JCCOV, MISS,
     +   NLPPC,  INLPPC, JNLPPC, CMISS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     ROUTINE TO LIST THE COMPUTED RESULTS FROM THE TIME SERIES
C     CROSS CORRELATION 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
      REAL
     +   CMISS
      INTEGER
     +   ICCOV,INLPPC,JCCOV,JNLPPC,LAGMAX,M
      LOGICAL
     +   MISS,STORE
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV(ICCOV,JCCOV,*)
      INTEGER
     +   NLPPC(INLPPC,JNLPPC,*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,J,K,L,L1,LAG
C
C  LOCAL ARRAYS
      REAL
     +   CCF(16)
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      EXTERNAL MVCHK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCF(16)
C        AN ARRAY USED FOR PRINTING THE CCF.
C     REAL CCOV(ICCOV,JCCOV,M)
C        THE CROSS COVARIANCE ARRAY.
C     REAL CMISS
C        THE MISSING VALUE CODE FOR THE RETURNED CCVF ESTIMATES
C        (VECTOR CCOV).
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER ICCOV
C        THE FIRST DIMENSION OF THE ARRAY CCOV.
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     INTEGER INLPPC
C        THE FIRST DIMENSION OF THE ARRAY NLPPC.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER J
C        AN INDEXING VARIABLE.
C     INTEGER JCCOV, JNLPPC
C        THE SECOND DIMENSIONS OF THE ARRAYS CCOV AND NLPPC,
C        RESPECTIVELY.
C     INTEGER K
C        AN INDEXING VARIABLE.
C     INTEGER L1
C        AN INDEX VARIABLE.
C     INTEGER LAG
C        THE LAG VALUE AT WHICH THE DATA IS BEING PRINTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE REQUESTED.
C     INTEGER M
C        THE NUMBER OF SERIES IN THE MULTIVARIATE TIME SERIES YM.
C     LOGICAL MISS
C        THE VALUE INDICATING WHETHER THE ANALYSIS INCLUDED MISSING
C        DATA (TRUE) OR NOT (FALSE).
C     INTEGER NLPPC(INLPPC,JNLPPC,M)
C        THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS
C        USED TO COMPUTE EACH CCVF ESTIMATE.
C     LOGICAL STORE
C        THE VALUE INDICATING WHETHER THE RESULTS WERE RETURNED
C        TO THE USER (TRUE) OR NOT (FALSE).
C
      CALL IPRINT(IPRT)
C
C     PRINT IERR
C
      WRITE (IPRT, 1000) IERR
C
      IF (IERR.NE.0) RETURN
C
C     CHECK FOR STORED RESULTS
C
      IF (.NOT.STORE) RETURN
C
C     PRINT HEADING FOR CCVF
C
      WRITE (IPRT, 1010)
      WRITE (IPRT, 1040) ((J,K, K=1,M), J=1,M)
C
C     PRINT CROSS COVARIANCES
C
      LAG = 0
      WRITE (IPRT, 1060) LAG, ((CCOV(1,J,K), K=1,M), J=1,M)
      DO 10 LAG = 1, LAGMAX
         WRITE (IPRT, 1060) LAG, ((CCOV(LAG+1,J,K), K=1,M), J=1,M)
   10 CONTINUE
C
C     PRINT HEADING FOR CCF
C
      WRITE (IPRT, 1020)
      WRITE (IPRT, 1040) ((J,K, K=1,M), J=1,M)
C
C     PRINT CROSS CORRELATIONS
C
      LAG = 0
      I = 0
      DO 30 J = 1, M
         DO 20 K = 1, M
            I = I + 1
            CCF(I) = CCOV(1,J,K) / SQRT(CCOV(1,J,J)*CCOV(1,K,K))
   20    CONTINUE
   30 CONTINUE
      WRITE (IPRT, 1060) LAG, (CCF(L), L=1,I)
C
      DO 60 LAG = 1, LAGMAX
         I = 0
         DO 50 J = 1, M
            DO 40 K = 1, M
               I = I + 1
               IF (.NOT.MISS) GO TO 35
               CCF(I) = CMISS
               IF (MVCHK(CCOV(LAG+1,J,K),CMISS)) GO TO 40
   35          CCF(I) = CCOV(LAG+1,J,K) / SQRT(CCOV(1,J,J)*CCOV(1,K,K))
   40       CONTINUE
   50    CONTINUE
         WRITE (IPRT, 1060) LAG, (CCF(L1), L1=1,I)
   60 CONTINUE
C
C     CHECK FOR MISSING VALUES
C
      IF (.NOT.MISS) RETURN
C
C     PRINT HEADING FOR NUMBERS OF LAGGED PRODUCT PAIRS
C
      WRITE (IPRT, 1030)
      WRITE (IPRT, 1040) ((J,K, K=1,M), J=1,M)
C
C     PRINT NUMBERS OF LAGGED PRODUCT PAIRS FOR EACH CCVF
C
      LAG = 0
      WRITE (IPRT, 1070) LAG, ((NLPPC(1,J,K), K=1,M), J=1,M)
      DO 70 LAG = 1, LAGMAX
         WRITE (IPRT, 1070) LAG, ((NLPPC(LAG+1,J,K), K=1,M), J=1,M)
   70 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//8H IERR = , I5)
 1010 FORMAT (// 6X, 6H  CCVF)
 1020 FORMAT (// 6X, 6H   CCF)
 1030 FORMAT (// 6X, 6H NLPPC)
 1040 FORMAT (1X, 3HLAG, 16(5X, I1, ',', I1))
 1060 FORMAT (1X, I3, 16F8.4)
 1070 FORMAT (1X, I3, 16I8)
      END
*CCVF
      SUBROUTINE CCVF(Y1, Y2, N, LAGMAX, Y1MEAN, Y2MEAN, CCOV12, CCOV21,
     +   ICCOV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE CROSS COVARIANCE FUNCTION
C     BETWEEN TWO SERIES.
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
      REAL
     +   Y1MEAN,Y2MEAN
      INTEGER
     +   ICCOV,LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV12(ICCOV),CCOV21(ICCOV),Y1(N),Y2(N)
C
C  LOCAL SCALARS
      REAL
     +   DOTXY
      INTEGER
     +   LAG,NDOTXY
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DOTC
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV12(ICCOV), CCOV21(ICCOV)
C        THE ARRAYS IN WHICH THE CCVF FOR SERIES 1 LAGGED
C        BEHIND SERIES 2 AND VISA VERSA, RESPECTIVELY, ARE
C        STORED.
C     REAL DOTXY
C        VARIOUS CROSS PRUDUCTS BETWEEN SERIES Y1 AND Y2.
C     INTEGER ICCOV
C        THE ROW DIMENSION OF THE ARRAYS CCOV12 AND CCOV21.
C     INTEGER LAG
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        AUTOCORRELATION BEING COMPUTED.
C     INTEGER LAGMAX
C        THE MAXIMUM NUMBER OF LAGS TO BE USED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NDOTXY
C        THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY.
C     REAL Y1(N), Y1MEAN
C        THE FIRST SERIES, AND ITS MEAN.
C     REAL Y2(N), Y2MEAN
C        THE SECOND SERIES, AND ITS MEAN.
C
C     COMPUTE THE CROSS COVARIANCES
C
      CALL DOTC ( Y1, Y1MEAN, N, Y2, Y2MEAN, N, DOTXY, NDOTXY)
      CCOV12(1) = DOTXY / N
      CCOV21(1) = CCOV12(1)
C
      DO 10 LAG = 1, LAGMAX
C
         CALL DOTC (Y1, Y1MEAN, N, Y2(LAG + 1), Y2MEAN, N - LAG,
     +       DOTXY, NDOTXY)
         CCOV12(LAG+1) = DOTXY / N
C
         CALL DOTC (Y2, Y2MEAN, N, Y1(LAG + 1), Y1MEAN, N - LAG,
     +       DOTXY, NDOTXY)
         CCOV21(LAG+1) = DOTXY / N
C
   10 CONTINUE
C
      RETURN
      END
*CCVFF
      SUBROUTINE CCVFF (YFFT1, YFFT2, N, NFFT, LAGMAX, CCOV12, CCOV21,
     +   ICCOV, LYFFT, WORK, LWORK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE CROSS COVARIANCE FUNCTION
C     BETWEEN TWO SERIES.
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
     +   ICCOV,LAGMAX,LWORK,LYFFT,N,NFFT
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV12(ICCOV),CCOV21(ICCOV),WORK(LWORK),YFFT1(LYFFT),
     +   YFFT2(LYFFT)
C
C  LOCAL SCALARS
      REAL
     +   FAC
      INTEGER
     +   I,ISN,J,LAG,NF,NF2,NFFT2
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FFT,REALTR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV12(ICCOV), CCOV21(ICCOV)
C        THE ARRAYS IN WHICH THE CCVF FOR SERIES 1 LAGGED
C        BEHIND SERIES 2 AND VISA VERSA, RESPECTIVELY, ARE STORED.
C     REAL FAC
C        THE APPROPRIATE FACTOR USED TO SCALE THE CCVF.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER ICCOV
C        THE DIMENSION OF THE ARRAYS CCOV12 AND CCOV21.
C     INTEGER LAG, LAGMAX
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        CROSS CORRELATION BEING COMPUTED, AND THE MAXIMUM LAG
C        VALUE TO BE USED.
C     INTEGER LWORK
C        THE DIMENSION OF THE VECTOR WORK.
C     INTEGER LYFFT
C        THE ACTUAL LENGTH OF THE ARRAYS YFFT1 AND YFFT2.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NF
C        THE NUMBER OF FOURIER FREQUENCIES.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NFFT2
C        THE EFFECTIVE NUMBER OF OBSERVATIONS FOR THE FFT TRANSFORM.
C     INTEGER NF2
C        TWICE THE NUMBER OF FOURIER FREQUENCIES.
C     REAL WORK(LWORK)
C        THE WORK ARRAY NEEDED FOR THE COMPUTATIONS.
C     REAL YFFT1(LYFFT), YFFT2(LYFFT)
C        THE VECTORS CONTAINING THE OBSERVED SERIES ALREADY PROCESSED
C        BY ONE PASS OF A FFT.
C
      NFFT2 = (NFFT-2) / 2
      NF = NFFT2 + 1
      NF2 = NF * 2
C
C     COMPUTE THE CROSS COVARIANCES
C
      DO 10 I = 2, NF2, 2
         WORK(I-1) = YFFT1(I-1)*YFFT2(I-1) + YFFT1(I)*YFFT2(I)
         WORK(I) = YFFT1(I)*YFFT2(I-1) - YFFT1(I-1)*YFFT2(I)
   10 CONTINUE
C
      FAC = 1.0E0 / (4 * (NFFT-2) * N)
C
      ISN = -2
C
      CALL REALTR (WORK, WORK(2), NFFT2, ISN)
C
      CALL FFT (WORK, WORK(2), NFFT2, NFFT2, NFFT2, ISN)
C
      CCOV12(1) = WORK(1) * FAC
      CCOV21(1) = CCOV12(1)
C
      DO 20 LAG = 1, LAGMAX
         CCOV21(LAG+1) = WORK(LAG+1) * FAC
C
         J = NFFT - 1 - LAG
         CCOV12(LAG+1) = WORK(J) * FAC
   20 CONTINUE
C
      RETURN
      END
*CCVFM
      SUBROUTINE CCVFM(Y1, Y1MISS, Y2, Y2MISS, N, NC, Y1MEAN, Y2MEAN,
     +   CCOV12, CCOV21, ICCOV, NLPP12, NLPP21)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE CROSS COVARIANCE FUNCTION
C     BETWEEN TWO SERIES WHEN MISSING DATA ARE INVOLVED.
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
      REAL
     +   Y1MEAN,Y1MISS,Y2MEAN,Y2MISS
      INTEGER
     +   ICCOV,N,NC
C
C  ARRAY ARGUMENTS
      REAL
     +   CCOV12(ICCOV),CCOV21(ICCOV),Y1(N),Y2(N)
      INTEGER
     +   NLPP12(ICCOV),NLPP21(ICCOV)
C
C  LOCAL SCALARS
      REAL
     +   DOTXY,FPLM
      INTEGER
     +   LAG,NDOTXY
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DOTCM
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CCOV12(ICCOV), CCOV21(ICCOV)
C        THE ARRAYS IN WHICH THE CCVF FOR SERIES 1 LAGGED
C        BEHIND SERIES 2 AND VISA VERSA, RESPECTIVELY, ARE
C        STORED.
C     REAL DOTXY
C        VARIOUS CROSS PRUDUCTS BETWEEN SERIES Y1 AND Y2.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER ICCOV
C        THE ROW DIMENSION OF THE ARRAYS CCOV12 AND CCOV21.
C     INTEGER LAG
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        AUTOCORRELATION BEING COMPUTED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NC
C        THE NUMBER OF CROSS CORRELATIONS DESIRED.
C     INTEGER NLPP12(ICCOV), NLPP21(ICCOV)
C        THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE THE CCVF
C        FOR EACH PAIR OF SERIES AT EACH LAG.
C     INTEGER NDOTXY
C        THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY.
C     REAL Y1(N), Y1MEAN, Y1MISS
C        THE FIRST SERIES, AND ITS MEAN, AND MISSING VALUE CODE.
C     REAL Y2(N), Y2MEAN, Y2MISS
C        THE SECOND SERIES, AND ITS MEAN, AND MISSING VALUE CODE.
C
      FPLM = R1MACH(2)
C
C     COMPUTE THE CROSS COVARIANCES
C
      CALL DOTCM (Y1, Y1MEAN, Y1MISS, N, Y2, Y2MEAN, Y2MISS, N, DOTXY,
     +   NDOTXY)
C
      NLPP12(1) = NDOTXY
      CCOV12(1) = FPLM
      IF (NDOTXY .GE. 1) CCOV12(1) = DOTXY / NDOTXY
C
      CCOV21(1) = CCOV12(1)
      NLPP21(1) = NDOTXY
C
      DO 10 LAG = 1, NC
C
         CALL DOTCM (Y1, Y1MEAN, Y1MISS, N, Y2(LAG+1), Y2MEAN, Y2MISS,
     +       N-LAG, DOTXY, NDOTXY)
C
         NLPP12(LAG+1) = NDOTXY
         CCOV12(LAG+1) = FPLM
         IF (NDOTXY .GE. 1)
     +      CCOV12(LAG+1) = DOTXY * (N-LAG) / (N*NDOTXY)
C
         CALL DOTCM (Y2, Y2MEAN, Y2MISS, N, Y1(LAG+1), Y1MEAN, Y1MISS,
     +      N-LAG, DOTXY, NDOTXY)
C
         NLPP21(LAG+1) = NDOTXY
         CCOV21(LAG+1) = FPLM
         IF (NDOTXY .GE. 1)
     +      CCOV21(LAG+1) = DOTXY * (N-LAG) / (N*NDOTXY)
C
   10 CONTINUE
C
      RETURN
      END
*CDFCHI
      REAL FUNCTION CDFCHI(CHISQR, DF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE CHI SQUARE CUMULATIVE DISTRIBUTION
C     FUNCTION FROM THE INCOMPLETE GAMMA FUNCTION RATIO AS DISCUSSED IN
C     CHAPTER 17 OF DISTRIBUTIONS IN STATISTICS - CONTINUOUS UNIVARIATE
C     DISTRIBUTIONS - 1, BY JOHNSON AND KOTZ.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   CHISQR,DF
C
C  LOCAL SCALARS
      REAL
     +   FPLPM
C
C  EXTERNAL FUNCTIONS
      REAL
     +    GAMI, GAMMA,R1MACH
      LOGICAL
     +   MVCHK
      EXTERNAL  GAMI, GAMMA,R1MACH,MVCHK
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CHISQR
C        THE PERCENT POINT FROM THE CHI SQUARED DISTRIBUTION.
C     REAL DF
C        THE DEGREES OF FREEDOM.
C     REAL FPLPM
C        THE REAL FLOATING POINT LARGEST POSITIVE MAGNITUDE.
C
C     COMMENCE BODY OF ROUTINE
C
      FPLPM = R1MACH(2)
C
      CDFCHI =  GAMI(0.5E0*DF, 0.5E0*CHISQR)
      IF (MVCHK(CDFCHI,FPLPM)) THEN
         CDFCHI = 1.0E0
      ELSE
         CDFCHI = CDFCHI /  GAMMA(0.5E0*DF)
         IF (CDFCHI.LT.0.0E0) CDFCHI = 0.0E0
         IF (CDFCHI.GT.1.0E0) CDFCHI = 1.0E0
      END IF
C
      RETURN
      END
*CDFF
      REAL FUNCTION CDFF(F, DF1, DF2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION FUNCTION FOR
C     THE F DISTRIBUTION.  THE APPROXIMATION USED DEPENDS ON THE
C     DEGREES OF FREEDOM IN THE NUMERATOR AND DENOMINATOR.
C     1.  IF BOTH DEGREES OF FREEDOM ARE SMALL (LESS THAN 4000),
C         THE CDF IS COMPUTED FROM THE INCOMPLETE BETA FUNCTION
C         USING EQUATION 5.45 OF STATISTICAL COMPUTING, BY KENNEDY AND
C         GENTLE.
C     2.  IF ONE OF THE DEGREES OF FREEDOM IS LARGE (GREATER THAN OR
C         EQUAL TO 4000) AND THE OTHER IS MODERATELY LARGE (GREATER THAN
C         OR EQUAL TO 100), THE CDF IS APPROXIMATED BY A NORMAL DISTRIB-
C         BUTION AS SHOWN IN EQUATION 20 ON PAGE 83 OF DISTRIBUTIONS IN
C         STATISTICS - CONTINUOUS UNIVARIATE DISTRIBUTIONS - 2, BY
C         JOHNSON AND KOTZ.
C     3.  IF ONE OF THE DEGREES OF FREEDOM IS SMALL (LESS THAN 100) AND
C         THE OTHER IS LARGE (EXCEEDING 4000), THE CDF IS APPROXIMATED
C         BY A CHI SQUARED DISTRIBUTION AS SHOWN IN THE THIRD EQUATION
C         ON PAGE 84 OF DISTRIBUTIONS IN STATISTICS - CONTINUOUS
C         UNIVARIATE DISTRIBUTIONS - 2, BY JOHNSON AND KOTZ.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE - DECEMBER 7, 1981
C                     THIS ROUTINE IS MODELED AFTER DATAPAC ROUTINE FCDF.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   DF1,DF2,F
C
C  LOCAL SCALARS
      REAL
     +   FTRANS
C
C  EXTERNAL FUNCTIONS
      REAL
     +    BETAI,CDFCHI,CDFNML
      EXTERNAL  BETAI,CDFCHI,CDFNML
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DF1
C        THE DEGREES OF FREEDOM IN THE NUMERATOR.
C     REAL DF2
C        THE DEGREES OF FREEDOM IN THE DENOMINATOR.
C     REAL F
C        THE PERCENTAGE POINT FROM THE F DISTRIBUTION.
C     REAL FTRANS
C        TRANSFORMS OF THE F PERCENTAGE POINT, USED FOR THE VARIOUS
C        APPROXIMATING DISTRIBUTIONS.
C
C     COMMENCE BODY OF ROUTINE
C
      IF (F.GT.0.0E0) GO TO 5
      CDFF = 0.0E0
      RETURN
C
    5 CONTINUE
C
      IF ((DF1.GT.4000.0E0) .OR. (DF2.GT.4000.0E0)) GO TO 10
C
C     BOTH DEGREES OF FREEDOM ARE LESS THAN OR EQUAL TO 4000.  USE
C     THE INCOMPLETE BETA FUNCTION TO COMPUTE THE F CDF.
C
      FTRANS = DF2 / (DF2 + DF1 * F)
C
      CDFF = 1.0E0 -  BETAI(FTRANS, 0.5E0*DF2, 0.5E0*DF1)
      RETURN
C
   10 IF ((DF1.LE.100.0E0) .OR. (DF2.LE.100.0E0)) GO TO 20
C
C     BOTH DEGREES OF FREEDOM EXCEED 4000.  USE THE NORMAL APPROXIMATION
C     TO COMPUTE THE F CDF.
C
      FTRANS =
     +   (((1.0E0-(2.0E0/(9.0E0*DF2)))*
     +     (F**(1.0E0/3.0E0)))-(1.0E0-(2.0E0/(9.0E0*DF1)))) /
     +   SQRT(((F**(2.0E0/3.0E0))/(4.5E0*DF2))+(2.0E0/(9.0E0*DF1)))
C
      CDFF = CDFNML(FTRANS)
      RETURN
C
   20 IF (DF1.GT.100.0E0) GO TO 30
C
C     THE DEGREES OF FREEDOM IN THE DENOMINATOR EXCEEDS 4000 AND THE
C     DEGREES OF FREEDOM IN NUMERATOR IS LESS THAN OR EQUAL TO 100.
C     USE THE CHI SQUARE APPROXIMATION TO COMPUTE THE F CDF.
C
      FTRANS =
     +   (DF1 + (DF1/DF2)*(0.5E0*DF1-1.0E0))/
     +   ((1.0E0/F)+(DF1/DF2)*0.5E0)
C
      CDFF = CDFCHI(FTRANS, DF1)
C
      RETURN
C
   30 CONTINUE
C
C     THE DEGREES OF FREEDOM IN THE NUMERATOR EXCEEDS 4000 AND THE
C     DEGREES OF FREEDOM IN DENOMINATOR IS LESS THAN OR EQUAL TO 100.
C     USE THE CHI SQUARE APPROXIMATION TO COMPUTE THE F CDF.
C
      FTRANS =
     +   (DF2+(DF2/DF1)*(0.5E0*DF2-1.0E0))/(F+(DF2/DF1)*0.5E0)
C
      CDFF = 1.0E0 - CDFCHI(FTRANS, DF2)
C
      RETURN
C
      END
*CDFNML
      REAL FUNCTION CDFNML(X)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE NORMAL CUMULATIVE DISTRIBUTION
C     FUNCTION FROM THE ERROR FUNCTION AS DESCRIBED IN CHAPTER 13
C     OF DISTRIBUTIONS IN STATISTICS - CONTINUOUS UNIVARIATE
C     DISTRIBUTIONS - 1, BY JOHNSON AND KOTZ.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   X
C
C  EXTERNAL FUNCTIONS
      REAL
     +    ERF
      EXTERNAL  ERF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL X
C        THE PERCENT POINT FROM THE CHI SQUARED DISTRIBUTION.
C
C     COMMENCE BODY OF ROUTINE
C
      CDFNML = 0.5E0 * (1.0E0 +  ERF(X/SQRT(2.0E0)))
C
      RETURN
      END
*CDFT
      REAL FUNCTION CDFT(X, IDF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR STUDENT"S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = IDF.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--X      = THE VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --IDF     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                IDF SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE STUDENT"S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = IDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--IDF SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDFC     LANGUAGE--ANSI FOR
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 948, FORMULAE 26.7.3 AND 26.7.4.
C               --JOHNSON AND KOTZ, CONTIIDFOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 94-129.
C               --FEDERIGHI, EXTENDED TABLES OF THE
C                 PERCENTAGE POINTS OF STUDENT"S
C                 T-DISTRIBUTION, JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION,
C                 1959, PAGES 683-688.
C               --OWEN, HANDBOOK OF STATISTICAL TABLES,
C                 1962, PAGES 27-30.
C               --PEARSON AND HARTLEY, BIOMETRIKA TABLES
C                 FOR STATISTICIANS, VOLUME 1, 1954,
C                 PAGES 132-134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --MAY       1974.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --OCTOBER   1976.
C
C---------------------------------------------------------------------
C
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   X
      INTEGER
     +   IDF
C
C  LOCAL SCALARS
      REAL
     +   B11,B21,B22,B23,B24,B25,B31,B32,B33,B34,B35,B36,B37,C,CSQ,D1,
     +   D11,D3,D5,D7,D9,DCONST,DF,FPSPM,PI,SD,SUM,TERM,TERM1,TERM2,
     +   TERM3,Z
      INTEGER
     +   I,IDFCUT,IEVODD,IMAX,IMIN,IPRT
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFNML,R1MACH
      EXTERNAL CDFNML,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,ATAN,EXP,LOG,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL B11, B21, B22, B23, B24, B25
C        CONSTANTS USED IN THE COMPUTATIONS.
C     REAL B31, B32, B33, B34, B35, B36, B37
C        CONSTANTS USED IN THE COMPUTATIONS.
C     REAL C
C        ...
C     REAL CSQ
C        ...
C     REAL DCONST
C        ...
C     REAL DF
C        THE DEGREES OF FREEDOM.
C     REAL D1, D11, D3, D5, D7, D9
C        CONSTANTS USED IN THE COMPUTATIONS.
C     REAL FPSPM
C        THE FLOATING POINT SMALLEST POSITIVE MAGNITUDE.
C     INTEGER I
C        AN INDEX.
C     INTEGER IDF
C        THE DEGREES OF FREEDOM.
C     INTEGER IDFCUT
C        ...
C     INTEGER IEVODD
C        ...
C     INTEGER IMAX
C        ...
C     INTEGER IMIN
C        ...
C     INTEGER IPRT
C        THE PRINT UNIT.
C     REAL PI
C        PI.
C     REAL SD
C        ...
C     REAL SUM
C        ...
C     REAL TERM, TERM1, TERM2, TERM3
C        ...
C     REAL X
C        THE T STATISTIC.
C     REAL Z
C        ...
C
      DATA IDFCUT /1000/
      DATA DCONST /0.3989422804E0/
      DATA B11 /0.25E0/
      DATA B21 /96.0E0/
C     DATA B21 /0.01041666666667E0/
      DATA B22, B23, B24, B25 /3.0E0,-7.0E0,-5.0E0,-3.0E0/
      DATA B31 /0.00260416666667E0/
      DATA B32, B33, B34, B35, B36, B37
     +    /1.0E0,-11.0E0,14.0E0,6.0E0,-3.0E0,-15.0E0/
C
C
      CALL GETPI(PI)
      CALL IPRINT(IPRT)
      FPSPM = R1MACH(1)
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF (IDF.LE.0) GO TO 10
      GO TO 20
   10 WRITE (IPRT, 1000)
      WRITE (IPRT, 1010) IDF
      CDFT = 0.0E0
      RETURN
   20 CONTINUE
C
C-----START POINT-----------------------------------------------------
C
      DF = IDF
C
C     IF IDF IS 3 THROUGH 9 AND X IS MORE THAN 3000
C     STANDARD DEVIATIONS BELOW THE MEAN,
C     SET CDFT = 0.0E0 AND RETURN.
C     IF IDF IS 10 OR LARGER AND X IS MORE THAN 150
C     STANDARD DEVIATIONS BELOW THE MEAN,
C     SET CDFT = 0.0E0 AND RETURN.
C     IF IDF IS 3 THROUGH 9 AND X IS MORE THAN 3000
C     STANDARD DEVIATIONS ABOVE THE MEAN,
C     SET CDFT = 1.0E0 AND RETURN.
C     IF IDF IS 10 OR LARGER AND X IS MORE THAN 150
C     STANDARD DEVIATIONS ABOVE THE MEAN,
C     SET CDFT = 1.0E0 AND RETURN.
C
      IF (IDF.LE.2) GO TO 50
      SD = SQRT(DF/(DF-2.0E0))
      Z = X/SD
      IF (IDF.LT.10 .AND. Z.LT.(-3000.0E0)) GO TO 30
      IF (IDF.GE.10 .AND. Z.LT.(-150.0E0)) GO TO 30
      IF (IDF.LT.10 .AND. Z.GT.3000.0E0) GO TO 40
      IF (IDF.GE.10 .AND. Z.GT.150.0E0) GO TO 40
      GO TO 50
   30 CDFT = 0.0E0
      RETURN
   40 CDFT = 1.0E0
      RETURN
   50 CONTINUE
C
C     DISTINGUISH BETWEEN THE SMALL AND MODERATE
C     DEGREES OF FREEDOM CASE VERSUS THE
C     LARGE DEGREES OF FREEDOM CASE
C
      IF (IDF.LT.IDFCUT) GO TO 60
      GO TO 120
C
C     TREAT THE SMALL AND MODERATE DEGREES OF FREEDOM CASE
C     METHOD UTILIZED--EXACT FINITE SUM
C     (SEE AMS 55, PAGE 948, FORMULAE 26.7.3 AND 26.7.4).
C
   60 CONTINUE
      CSQ = DF/(X*X+DF)
      C = SQRT(CSQ)
      IMAX = IDF - 2
      IEVODD = IDF - 2*(IDF/2)
      IF (IEVODD.NE.0) THEN
         IF (IDF.EQ.1) THEN
            SUM = 0.0E0
         ELSE
            SUM = C
         END IF
         TERM = C
         IMIN = 3
      ELSE
         SUM = 1.0E0
         TERM = 1.0E0
         IMIN = 2
      END IF
C
      DO 90 I=IMIN,IMAX,2
         IF (TERM.NE.0.0E0) THEN
            IF (LOG(TERM)+LOG((I-1.0E0)/I)+LOG(CSQ).GE.LOG(FPSPM)) THEN
               TERM = TERM*((I-1.0E0)/I)*CSQ
               SUM = SUM + TERM
            ELSE
               TERM = 0.0E0
            END IF
         END IF
   90 CONTINUE
C
      IF (SUM.EQ.0.0E0 .OR. X.EQ.0.0E0) THEN
         SUM = 0.0E0
      ELSE
         IF (LOG(SUM)+LOG(ABS(X))-0.5*LOG(X*X+DF) .LT. LOG(FPSPM)) THEN
            SUM = 0.0E0
         ELSE
            SUM = SUM*X/SQRT(X*X+DF)
         END IF
      END IF
      IF (IEVODD.EQ.0) GO TO 110
      SUM = (2.0E0/PI)*(ATAN(X/SQRT(DF))+SUM)
  110 CDFT = 0.5E0 + SUM/2.0E0
      RETURN
C
C     TREAT THE LARGE DEGREES OF FREEDOM CASE.
C     METHOD UTILIZED--TRUNCATED ASYMPTOTIC EXPANSION
C     (SEE JOHNSON AND KOTZ, VOLUME 2, PAGE 102, FORMULA 10?
C     SEE FEDERIGHI, PAGE 687).
C
  120 CONTINUE
      D1 = X
      D3 = X**3
      D5 = X**5
      D7 = X**7
      D9 = X**9
      D11 = X**11
      TERM1 = B11*(D3+D1)/DF
C     TERM2 = B21*(B22*D7+B23*D5+B24*D3+B25*D1)/(DF**2)
      TERM2 = (B22*D7+B23*D5+B24*D3+B25*D1)/(DF**2) / B21
      TERM3 = B31*(B32*D11+B33*D9+B34*D7+B35*D5+B36*D3+B37*D1)/(DF**3)
      CDFT = TERM1 + TERM2 + TERM3
      CDFT = CDFNML(X) - (DCONST*(EXP(-X*X/2.0E0)))*CDFT
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (' ', 49H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO T,
     +   42HHE CDFT   SUBROUTINE IS NON-POSITIVE *****)
 1010 FORMAT (' ', 35H***** THE VALUE OF THE ARGUMENT IS , I8, 6H *****)
      END
*CENTER
      SUBROUTINE CENTER (Y, N, YC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER ROUTINE FOR CENTERING THE OBSERVED SERIES Y,
C     RETURNING THE CENTERED SERIES IN YC.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YC(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      LOGICAL
     +   ERR01,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CNTR,EISGE,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT NUMBER USED FOR OUTPUT.
C     CHARACTER*1 LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
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     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YC(N)
C        THE VECTOR IN WHICH THE CENTERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'C',       'E',       'N',       'T',       'E',       'R'/
      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, 2, 1, HEAD, ERR01, LN)
      IF (.NOT. ERR01) GO TO 5
C
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
    5 CONTINUE
C
      CALL CNTR (Y, N, YC)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   29H       CALL CENTER (Y, N, YC))
      END
*CHIRHO
      SUBROUTINE CHIRHO (RHO, N, NC, CHI, CHIP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE CHI SQUARED STATISTIC AND ITS
C     PROBABILITY BASED IN A VECTOR OF AUTOCORRELATIONS.
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
      REAL
     +   CHI,CHIP
      INTEGER
     +   N,NC
C
C  ARRAY ARGUMENTS
      REAL
     +   RHO(*)
C
C  LOCAL SCALARS
      INTEGER
     +   LAG
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFCHI
      EXTERNAL CDFCHI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC REAL
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CHI, CHIP
C        THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND
C        CHI SQUARE STATISTIC PROBABILITY ARE STORED.
C     INTEGER LAG
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        AUTOCORRELATION BEING EXAMINED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NC
C        THE NUMBER OF AUTOCORRELATIONS COMPUTED.
C     REAL RHO(NC)
C        THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED
C
      CHI = 0.0E0
      DO 10 LAG = 1, NC
         CHI = CHI + RHO(LAG) * RHO(LAG)
   10 CONTINUE
      CHI = CHI * N
      CHIP = 1.0E0 - CDFCHI(CHI, REAL(NC))
      RETURN
      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
      REAL
     +   STP
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   FD(*),PV(*),PVSTP(*)
C
C  LOCAL SCALARS
      REAL
     +   FPLRS
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     REAL FD(N)
C        THE FINITE-DIFFERENCE DERIVATIVE.
C     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     REAL PV(N)
C        THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE.
C     REAL PVSTP(N)
C        THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE PLUS STP.
C     REAL STP
C        THE STEP.
C
      FPLRS = R1MACH(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.0E0
         END IF
   10 CONTINUE
      RETURN
      END
*CNTR
      SUBROUTINE CNTR (Y, N, YC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CENTERS THE INPUT SERIES Y ABOUT ITS MEAN,
C     RETURNING THE CENTERED SERIES IN YC.
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YC(*)
C
C  LOCAL SCALARS
      REAL
     +   YMEAN
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE INPUT SERIES.
C     REAL Y(N)
C        THE INPUT ARRAY OF OBSERVATIONS TO BE CENTERED.
C     REAL YC(N)
C        THE OUTPUT ARRAY OF CENTERED OBSERVATIONS.
C     REAL YMEAN
C        THE MEAN OF THE INPUT SERIES.
C
      CALL AMEAN (Y, N, YMEAN)
C
      DO 10 I = 1, N
         YC(I) = Y(I) - YMEAN
   10 CONTINUE
C
      RETURN
C
      END
*CORRER
      SUBROUTINE CORRER(NMSUB, M, N, IYM, IVCV, LDSTAK, ICOR, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS FOR ERRORS IN THE INPUT
C     PARAMETERS.  IF ANY ARE FOUND A FLAG IS SET AND
C     COMPUTATION STOPS
C
C     WRITTEN BY -
C        LINDA L. MITCHELL
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ICOR,IVCV,IYM,LDSTAK,M,N,NPRT
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IP,IPRT,IS,LDSMIN
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LIVCV(8)*1,LIYM(8)*1,LLDS(8)*1,LM(8)*1,LN(8)*1,
     +   LTHREE(8)*1,LTWO(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,IPRINT,LDSCMP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05
C                  VALUE(S) INDICATING WHETHER OR ERROR WAS DETECTED
C                  (TRUE) OR NOT (FALSE).
C     LOGICAL HEAD
C                  A FLAG INDICATING WHETHER THE HEADING SHOULD BE
C                  PRINTED (TRUE) OR NOT (FALSE).  IF A HEADING IS
C                  PRINTED, THE VALUE OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER ICOR
C                  DETERMINES WHICH SUBROUTINE CALLED CORRER
C                  IF =1, THEN CALLED BY CORR
C                     =2, THEN CALLED BY CORRS
C     INTEGER IERR
C                  A FLAG, THAT WHEN RETURNED BY THIS ROUTINE DESIGNATES
C                  WHETHER  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 IP
C                  A TEMPORARY VARIABLE USED FOR COMPUTING LDSMIN.
C     INTEGER IPRT
C                  THE LOGICAL OUTPUT UNIT
C     INTEGER IS
C                  A TEMPORARY VARIABLE USED FOR COMPUTING LDSMIN.
C     INTEGER IVCV
C                  THE DIMENSION OF SC
C     INTEGER IYM
C                  ACTUAL ROW DIMENSION OF YM
C     INTEGER LDSMIN
C                  THE MINIMUM LENGTH ALLOWED FOR DSTAK
C     INTEGER LDSTAK
C                  THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK
C     CHARACTER*1 LIVCV(8), LIYM(8), LLDS(8), LM(8), LN(8), LTHREE(8),
C    *  LTWO(8)
C                  THE ARRAY(S) CONTAINING THE NAME(S) OF THE
C                  VARIABLE(S) CHECKED FOR ERRORS.
C     INTEGER M
C                  NUMBER OF VARIABLES
C     INTEGER N
C                  THE NUMBER OFOBSERVATIONS
C     CHARACTER*1 NMSUB(6)
C                  THE NAME OF THE CALLING SUBROUTINE.
C     INTEGER NPRT
C                  THE VARIABLE CONTROLLING THE PRINTED OUTPUT.
C                  IF NPRT=0, OUTPUT IS SUPPRESSED, OTHERWISE IT IS NOT
C
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   LIYM(1),  LIYM(2),  LIYM(3),  LIYM(4),  LIYM(5),  LIYM(6),
     +       LIYM(7),  LIYM(8) / 'I', 'Y', 'M', ' ', ' ', ' ', ' ', ' '/
      DATA   LLDS(1),  LLDS(2),  LLDS(3),  LLDS(4),  LLDS(5),  LLDS(6),
     +       LLDS(7),  LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/
      DATA     LM(1),    LM(2),    LM(3),    LM(4),    LM(5),    LM(6),
     +         LM(7),    LM(8) / 'M', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA     LN(1),    LN(2),    LN(3),    LN(4),    LN(5),    LN(6),
     +         LN(7),    LN(8) / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA LTHREE(1),LTHREE(2),LTHREE(3),LTHREE(4),LTHREE(5),LTHREE(6),
     +     LTHREE(7),LTHREE(8) / 'T', 'H', 'R', 'E', 'E', ' ', ' ', ' '/
      DATA   LTWO(1),  LTWO(2),  LTWO(3),  LTWO(4),  LTWO(5),  LTWO(6),
     +       LTWO(7),  LTWO(8) / 'T', 'W', 'O', ' ', ' ', ' ', ' ', ' '/
C
      CALL IPRINT(IPRT)
C
      HEAD = .TRUE.
C
      IERR = 0
C
C     BEGIN ERROR CHECKING. THE COMMENTS STATE WHAT CONSTITUTES AN
C     ERROR. COMMENTS ENCLOSED BY STARS(**) INDICATE THE ERROR CONDITION
C
C     **NUMBER OF VARIABLES LESS THAN 2**
C
      CALL EISGE(NMSUB, LM, M, 2, 2, HEAD, ERR01, LTWO)
C
C     **NUMBER OF OBSERVATIONS LESS THAN 3**
C
      CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, ERR02, LTHREE)
C
C     **OBSERVATION MATRIX DIMENSIONED LESS THAN N**
C
      ERR03 = .FALSE.
      IF (.NOT.ERR02) CALL EISGE(NMSUB, LIYM, IYM, N, 3, HEAD, ERR03,
     +   LN)
C
C     **SC MATRIX DIMENSIONED LESS THAN M**
C
      ERR04 = .FALSE.
      IF ((ICOR.EQ.2) .AND. (.NOT.ERR01)) CALL EISGE(NMSUB, LIVCV,
     +   IVCV, M, 3, HEAD, ERR04, LM)
C
      IF (ERR01 .OR. ERR02) GO TO 40
      IS = 0
      IF (ICOR.EQ.1) IS = 1
C
      IP = 1
      IF (NPRT.EQ.0) IP = 0
C
C
C     CHECK FOR ENOUGH COMMON FOR THIS PROBLEM
C
      CALL LDSCMP(12, 0, IP*MAX(N,M), 0, 0, 0, 'S',
     +   IS*M*M + IP*(MAX(N,M)+M+N*(M+3)+6*M*M), LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR05, LLDS)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05) GO TO 40
      RETURN
C
C     SET IERR TO INDICATE AN ERROR
C
   40 CONTINUE
      IERR = 1
      RETURN
      END
*CORR
      SUBROUTINE CORR(YM, N, M, IYM, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR THE CORRELATION FAMILY.
C     IT IS THE SHORT CALL FORM.
C     THIS PROCEDURE CALLS CORER TO CHECK FOR ERRORS IN THE PARAMETER
C     LIST.  IF NO PROBLEMS IT THEN ALLOCATES SPACE IN CSTAK FOR THE
C     VECTORS NEEDED AND CALLS THE MAIN ROUTINE , CORRMN, TO
C     DO THE CORRELATION ANALYSIS.
C
C     WRITTEN BY -
C        LINDA L. MITCHELL
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IYM,LDSTAK,M,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   AVG,CILO,CIUP,ICOR,IFP,IPRT,IWRK,LIWRK,LWRK,NALL0,NPRT,PC,
     +   QF,QUAD,RANK,SC,SCINV,SD,SLPC,SLSC,SRCC,T,VCV,WRK
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CORRER,CORRMN,IPRINT,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER AVG
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  AVERAGES OF YM
C     INTEGER CILO
C                  OCCUPIES THE SAME SPACE AS SLPC AND IS THE LOWER
C                  CONFIDENCE INTERVAL
C     INTEGER CIUP
C                  OCCUPIES THE SAME SPACE AS SLSC AND IS THE UPPER
C                  CONFIDENCE INTERVAL
C     DOUBLE PRECISION DSTAK(12)
C                  THE DOUBLE PRECISION VERSION OF
C                  THE /CSTAK/ WORK AREA.
C     INTEGER ICOR
C                  DETERMINES WHICH SUBROUTINE CALLED CORRMN
C                  IF =1, THEN CALLED BY CORR
C                     =2, THEN CALLED BY CORRS
C     INTEGER IERR
C                  A FLAG RETURNED TO THE USER INDICATING
C                  WHETHER  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 IFP
C                  AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3
C                  INDICATES SINGLE PRECISION AND IFP=4 INDICATES
C                  DOUBLE PRECISION.
C     INTEGER IPRT
C                  LOGICAL OUTPUT UNIT
C     INTEGER ISTAK(12)
C                  THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IWRK
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  INTEGER WORK VECTOR.
C     INTEGER IYM
C                  THE ROW DIMENSION OF YM SPECIFIED IN THE USERS PROGRA
C     INTEGER LDSTAK
C                  SIZE OF WORK AREA ALLOCATED IN THE USERS PROGRAM
C     INTEGER LIWRK
C                  THE LENGTH OF THE INTEGER WORK VECTOR.
C     INTEGER LWRK
C                  THE LENGTH OF THE REAL WORK VECTOR.
C     INTEGER M
C                  THE NUMBER OF VARIABLES
C     INTEGER N
C                  THE NUMBER OF OBSERVATIONS
C     INTEGER NALL0
C                  THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE
C                  TIME THAT THIS ROUTINE WAS CALLED.
C     CHARACTER*1 NMSUB(6)
C                  THE SUBROUTINE NAME
C     INTEGER NPRT
C                  THE VARIABLE CONTROLLING THE AUTOMATIC PRINTOUT
C                       NPRT = 0, PRINTOUT IS SUPPRESSED
C                       OTHERWISE THE PRINTOUT IS PROVIDED.
C     INTEGER PC
C                  THE STARTING LOCATION IN THE WORK AREA
C                  OF THE PARTIAL CORRELATION COEFFICIENTS MATRIX
C     INTEGER QF
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  QUADRATIC FIT
C     INTEGER QUAD
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  REAL VERSION OF THE QUADRATIC FIT
C     INTEGER RANK
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  MATRIX CONTAINING THE RANKS OF YM
C     REAL RSTAK(12)
C                  THE REAL VERSION OF THE
C                  /CSTAK/ WORK AREA.
C     INTEGER SC
C                  THE STARTING LOCATION IN THE WORK AREA
C                  OF THE SIMPLE CORRELATION COEFFICIENTS MATRIX
C     INTEGER SCINV
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  INVERSE MATRIX OF SC
C     INTEGER SD
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  STANDARD DEVIATIONS OF YM
C     INTEGER SLPC
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  SIGNIFICANCE LEVELS OF PC
C     INTEGER SLSC
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  SIGNIFICANCE LEVELS OF SC
C     INTEGER SRCC
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  SPEARMAN RANK COEFFICIENTS
C     INTEGER T
C                  STARTING LOCATION IN THE WORK AREA
C                  FOR THE ARRAY T.
C     INTEGER VCV
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  VARIANCE COVARIANCE MATRIX.
C     INTEGER WRK
C                  THE STARTING LOCATION IN THE WORK AREA FOR
C                  WORK SPACE
C     REAL YM(IYM,M)
C                  THE MATRIX IN WHICH THE OBSERVATIONS ARE PASSED
C
C
C     SET UP NAME ARRAY
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'C',      'O',      'R',      'R',      ' ',      ' '/
C
C     SET UP FRAMEWORK VARIABLES FOR NUMBER TYPE
C
      IFP = 3
C
C     SET CALLER FLAG, THIS IS CORR
C
      ICOR = 1
C
C     PRINTOUT IS AUTOMATICALY PROVIDED
C
      NPRT = 1
C
C     CHECK FOR ERRORS IN PARAMETERS
C
      CALL CORRER(NMSUB, M, N, IYM, M, LDSTAK, ICOR, NPRT)
C
C     IF THERE IS AN ERROR RETURN TO THE CALLERS ROUTINE
C
      IF (IERR.EQ.0) GO TO 10
C
C     PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     INITIALIZE THE STACK
C
   10 CALL STKSET (LDSTAK, 4)
      NALL0 = STKST(1)
C
C     ALLOCATE SPACE IN CSTAK FOR MATRICES.
C
      LIWRK = MAX(N,M)
      LWRK = LIWRK
C
      VCV = STKGET(M*M,IFP)
      IWRK = STKGET(LIWRK,2)
      WRK = STKGET(LWRK,IFP)
C
      T = STKGET(M,IFP)
      RANK = STKGET(N*M,IFP)
      SCINV = STKGET(M*M,IFP)
      SLSC = STKGET(M*M,IFP)
      SLPC = STKGET(M*M,IFP)
      SC = STKGET(M*M,IFP)
      PC = STKGET(M*M,IFP)
      QUAD = STKGET(3*N,IFP)
      QF = STKGET(M*M,IFP)
C
C     THE FOLLOWING VARIABLES HAVE BEEN INDIRECTLY EQUIVALENCED-
C
      CIUP = SLSC
      CILO = SLPC
      AVG = WRK
      SD = WRK
      SRCC = SCINV
C
C     CALL THE ROUTINE TO DO THE COMPUTATIONS
C
      CALL CORRMN(YM, N, M, IYM, RSTAK(AVG), RSTAK(SD), RSTAK(T),
     +   RSTAK(RANK), RSTAK(SC), RSTAK(PC), RSTAK(SCINV), ISTAK(IWRK),
     +   RSTAK(WRK), RSTAK(SLSC), RSTAK(SLPC), RSTAK(SRCC),
     +   RSTAK(QUAD), RSTAK(CIUP), RSTAK(CILO), RSTAK(QF),
     +   NPRT, RSTAK(VCV), M, LIWRK, LWRK)
C
C     RETURN AREA TO THE WORK ARRAY
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENT
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL CORR (YM, N, M, IYM, LDSTAK)')
      END
*CORRHD
      SUBROUTINE CORRHD(IPRT, M, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A SUBROUTINE TO PRINT OUT THE HEADING FOR THE CORRELATION FAMILY.
C
C     AUTHOR -
C        JOHN E. KOONTZ
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IPRT,M,N
C
C  EXTERNAL SUBROUTINES
      EXTERNAL VERSP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE OUTPUT LOGICAL UNIT NUMBER
C     INTEGER M
C        THE NUMBER OF VARIABLES
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS FOR EACH VARIABLE
C
      CALL VERSP(.TRUE.)
      WRITE (IPRT,1000) M, N
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/25H CORRELATION ANALYSIS FOR, I3, 15H VARIABLES WITH,
     +   I5, 13H OBSERVATIONS/)
      END
*CORRMN
      SUBROUTINE CORRMN(YM, N, M, IYM, AVG, SD, T, RANK, SC, PC, SCINV,
     +   IWRK, WRK, SLSC, SLPC, SRCC, QUAD, CIUP, CILO, QF, NPRT,
     +   VCV, IVCV, LIWRK, LWRK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN ROUTINE FOR THE CORRELATION FAMILY, IT WAS
C     ADAPTED FROM THE OMNITAB ROUTINE CORREL. IT DOES A  CORRELATION
C     ANALYSIS OF A MULTIVARIATE RANDOM SAMPLE.
C     THE FOLLOWING TABLES ARE PRODUCED
C        SIMPLE CORRELATION COEFFICIENTS,
C        PARTIAL CORRELATION COEFFICIENTS,
C        AND THEIR SIGINIFICANCE LEVELS,
C        SPEARMAN RANK COEFFICIENTS,
C        QUADRATIC RELATIONSHIP,
C        95 AND 99 PERCENT CONFIDENCE INTERVALS.
C
C     THIS ROUTINE WAS ADAPTED FROM AN OMNITAB ROUTINE.
C
C     ADAPTED BY -
C        JANET R. DONALDSON AND LINDA L. MITCHELL
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IVCV,IYM,LIWRK,LWRK,M,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   AVG(M),CILO(M,M),CIUP(M,M),PC(M,M),QF(M,M),QUAD(N,3),
     +   RANK(N,M),SC(M,M),SCINV(M,M),SD(M),SLPC(M,M),SLSC(M,M),
     +   SRCC(M,M),T(M),VCV(IVCV,M),WRK(LWRK),YM(IYM,M)
      INTEGER
     +   IWRK(LIWRK)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   B,F,FN3,FPLM,HL1,HL2,SQSUM,SUM,Z,ZZ
      INTEGER
     +   I,IER,IPRT,J,K,K1,K2,NSUM
C
C  LOCAL ARRAYS
      REAL
     +   C(3),D(3),RR(3,3),XX(3)
      INTEGER
     +   INERT(3)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFF,R1MACH
      EXTERNAL CDFF,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,CORRHD,DOTC,IPRINT,MATPRT,MGS,RANKO,SSIDI,SSIFA,
     +   VCVOUT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,INT,LOG,MAX,MIN,REAL,SIGN,SQRT,TANH
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AVG(M)
C                  CONTAINS THE COLUMN AVERAGES OF YM
C     REAL B
C                  = (N-1) * N * (N+1) / 6
C     REAL C(3)
C                  *
C     REAL CILO(M,M)
C                  LOWER CONFIDENCE INTERVAL FOR SC
C     REAL CIUP(M,M)
C                  UPPER CONFIDENCE INTERVAL FOR SC
C     REAL D(3)
C                  A DUMMY ARRAY.
C     REAL F
C                  SQUARE ROOT OF FN3
C     REAL FN3
C                  REAL REPRESENTATION OF (N-3).
C     REAL FPLM
C                  THE FLOATING POINT LARGEST MAGNITUDE
C     REAL HL1
C                  *
C     REAL HL2
C                  *
C     INTEGER I
C                  AN INDEX VARIABLE
C     INTEGER IER
C                  ERROR FLAG FOR SUBROUTINES CALLED FROM THIS ROUTINE
C     INTEGER IERR
C                  WHEN RETURNED BY THIS ROUTINE, DESGINATES WHETHER ANY
C                  ERRORS WERE DETECTED DURING COMPUTATIONS
C                     IF IERR .EQ. 0, NO ERRORS
C                             .EQ. 1, ERRORS WERE DETECTED
C     INTEGER INERT(3)
C                  THE INERTIA OF THE SIMPLE CORRELATION MATRIX.
C     INTEGER IPRT
C                  THE LOGICAL OUTPUT NUMBER
C     INTEGER IVCV
C                  THE ROW DIMENSION OF VCV SPECIFIED IN THE USERS PROGR
C     INTEGER IWRK(LIWRK)
C                  A WORK VECTOR FOR THE INVERSION ROUTINE
C     INTEGER IYM
C                  THE ROW DIMENSION OF YM SPECIFIED IN THE USERS PROGRA
C     INTEGER J
C                  AN INDEX VARIABLE
C     INTEGER K
C                  AN INDEX VARIABLE
C     INTEGER K1
C                  *
C     INTEGER K2
C                  *
C     INTEGER LIWRK
C                  THE LENGTH OF THE INTEGER WORK VECTOR.
C     INTEGER LWRK
C                  THE LENGTH OF THE REAL WORK VECTOR.
C     INTEGER M
C                  THE NUMBER OF VARIABLES (THE COLUMN DIMENSION OF YM)
C     INTEGER N
C                  THE NUMBER OF OBSERVATIONS
C     INTEGER NPRT
C                  THE VARIABLE CONTROLLING THE AUTOMATIC PRINTOUT
C                  NPRT =0, PRINTOUT IS SUPPRESSED
C                  OTHERWISE PRINTOUT IS PROVIDED
C     INTEGER NSUM
C                  THE NUMBER OF OBSERVATIONS IN THE DOT PRODUCT
C     REAL PC(M,M)
C                  PARTIAL CORRELATION COEFFICIENTS MATRIX
C     REAL QF(M,M)
C                  QUADRATIC FIX MATRIX
C     REAL QUAD(N,3)
C                  DOUBLE VERSION OF QF MATRIX
C     REAL RANK(N,M)
C                  THE MATRIX CONTAING THE RANKS OF YM
C     REAL RR(3,3)
C                  *
C     REAL SC(M,M)
C                  SIMPLE CORRELATION COEFFICIENTS MATRIX
C     REAL SCINV(M,M)
C                  THE INVERSE MATRIX OF SC
C     REAL SD(M)
C                  STANDARD DEVIATION OF THE COMLUMNS OF YM
C     REAL SLPC(M,M)
C                  SIGNIFICANCE LEVELS OF PC
C     REAL SLSC(M,M)
C                  SIGNIFICANCE LEVELS OF SC
C     REAL SQSUM
C                  THE SUM OF SQUARES OF THE ITH COLUMN OF YM
C     REAL SRCC(M,M)
C                  SPEARMAN RANK CORRELATION COEFFICIENTS
C     REAL SUM
C                  USED IN CALCULATING THE STATISTICS OF YM
C     REAL T(M)
C                  USED IN DETERMINING SRCC
C     REAL VCV(IVCV,M)
C                  THE VARIANCE COVARIANCE MATRIX.
C     REAL WRK(LWRK)
C                  WORK STORAGE
C     REAL XX(3)
C                  *
C     REAL YM(IYM,M)
C                  THE MATRIX WHOSE COLUMNS EACH CONTAIN ONE OF M SETS
C                  OF N OBSERVATIONS. EACH COLUMN REPRESENTS A DIFFERENT
C                  VARIABLE
C     REAL Z
C                  USED IN COMPUTING CONFIDENCE INTERVALS
C     REAL ZZ
C                  USED IN DETERMINING CORRELATION COEFFICIENTS
C
      IERR = 0
C
      FPLM = R1MACH(2)
      CALL IPRINT(IPRT)
C
      DO 10 J=1,M
         CALL AMEAN(YM(1,J), N, AVG(J))
   10 CONTINUE
C
C     COMPUTE VARIANCE-COVARIANCE MATRIX
C
      DO 30 J=1,M
         DO 20 I=J,M
            CALL DOTC(YM(1,J), AVG(J), N, YM(1,I), AVG(I), N, SUM, NSUM)
            VCV(J,I) = SUM/(NSUM-1)
            VCV(I,J) = VCV(J,I)
   20    CONTINUE
   30 CONTINUE
C
      IF (NPRT.EQ.0) RETURN
C
C     PRINT VARIANCE-COVARIANCE MATRIX AND SIMPLE CORRELATION
C     COEFFICIENTS
C
      CALL CORRHD(IPRT, M, N)
      CALL VCVOUT(M, VCV, IVCV, .FALSE.)
C
C     COMPUTE STANDARD DEVIATIONS
C
      DO 40 I=1,M
         IF (VCV(I,I).LE.0.0E0) GO TO 90
         SD(I) = SQRT(VCV(I,I))
   40 CONTINUE
C
C     COMPUTE SIMPLE CORRELATION COEFFICIENTS
C
      DO 60 J=1,M
         DO 50 I=J,M
            SC(I,J) = 1.0E0
            SCINV(J,I) = 1.0E0
            IF (I.EQ.J) GO TO 50
            SC(I,J) = VCV(I,J)/SD(I)/SD(J)
            SC(J,I) = SC(I,J)
            SCINV(J,I) = SC(I,J)
   50    CONTINUE
   60 CONTINUE
C
      IF ((M.LE.2) .OR. (N.LE.M)) GO TO 190
C
C     CALCULATE PARTIAL CORRELATION COEFFICIENTS.
C
      CALL SSIFA(SCINV, M, M, IWRK, IER)
      IF (IER.EQ.0) GO TO 100
   90 WRITE (IPRT,1000)
      IERR = 1
      RETURN
  100 CONTINUE
      CALL SSIDI(SCINV, M, M, IWRK, D, INERT, WRK, 1)
      DO 130 J=1,M
         DO 120 I=J,M
            PC(I,J) = 1.0E0
            IF (I.EQ.J) GO TO 120
            ZZ = SCINV(I,I)*SCINV(J,J)
            PC(I,J) = FPLM
            IF (ZZ.LE.0.0E0) GO TO 110
            PC(I,J) = -SCINV(J,I)/SQRT(ZZ)
            IF (ABS(PC(I,J)).GT.1.0E0) PC(I,J) = SIGN(1.0E0,PC(I,J))
  110       PC(J,I) = PC(I,J)
  120    CONTINUE
C
  130 CONTINUE
C
C     COMPUTE SIGNIFICANCE LEVELS OF PARTIAL CORRELATION COEFFICIENTS.
C     NOTE, LOWER TRIANGULAR MATRIX STORED IN SQUARE MATRIX.
C
      DO 180 I=1,M
         DO 170 J=1,I
            IF (PC(I,J).NE.0.0E0) GO TO 140
            SLPC(I,J) = 1.0E0
            GO TO 170
  140       IF (ABS(PC(I,J)).LT.1.0E0) GO TO 150
            SLPC(I,J) = 0.0E0
            GO TO 170
  150       F = PC(I,J)*PC(I,J)
            IF (1.0E0-F.NE.0.0E0) GO TO 160
            SLPC(I,J) = FPLM
            GO TO 170
  160       F = (N-M)*F/(1.0E0-F)
            SLPC(I,J) = 1.0E0 - CDFF(F,1.0E0,REAL(N-M))
  170    CONTINUE
  180 CONTINUE
C
C     COMPUTE SIGNIFICANCE LEVELS OF SIMPLE CORRELATION COEFFICIENTS
C     NOTE, ONLY LOWER TRIANGULAR STORED IN SQUARE MATRIX.
C
  190 DO 250 I=1,M
         DO 240 J=1,I
            IF (I.NE.J) GO TO 200
            SLSC(I,J) = 0.0E0
            GO TO 240
  200       IF (SC(I,J).NE.0.0E0) GO TO 210
            SLSC(I,J) = 1.0E0
            GO TO 240
  210       IF (ABS(SC(I,J)).LT.1.0E0) GO TO 220
            SLSC(I,J) = 0.0E0
            GO TO 240
  220       F = SC(I,J)*SC(I,J)
            IF (F.NE.1.0E0) GO TO 230
            SLSC(I,J) = FPLM
            GO TO 240
  230       F = (N-2)*F/(1.0E0-F)
            SLSC(I,J) = 1.0E0 - CDFF(F,1.0E0,REAL(N-2))
  240    CONTINUE
  250 CONTINUE
C
C     PRINT SIGNIFICANCE LEVELS OF SIMPLE CORRELATION COEFFICIENTS,
C     PARTIAL CORRELATION COEFFICIENTS AND SIGNIFICANCE LEVELS
C
      WRITE (IPRT,1020)
      CALL MATPRT(SLSC, SLSC, M, IPRT, 0, 1, M)
      IF ((M.GT.2) .AND. (N.GT.M)) GO TO 260
      WRITE (IPRT,1010)
      GO TO 270
  260 I = M - 2
      WRITE (IPRT,1030) I
      CALL MATPRT(PC, PC, M, IPRT, 0, 1, M)
      WRITE (IPRT,1040)
      CALL MATPRT(SLPC, SLPC, M, IPRT, 0, 1, M)
  270 CONTINUE
C
C     DETERMINE THE RANKS OF THE OBSERVATIONS.
C
      DO 280 I=1,M
         CALL RANKO(N, YM(1,I), IWRK, RANK(1,I), T(I))
         T(I) = T(I) / 12.0E0
  280 CONTINUE
C
C     COMPUTE SPEARMAN RANK CORRELATION COEFFICIENTS.
C     NOTE, LOWER TRIANGULAR MATRIX, STORED IN SQUARE MATRIX.
C
      B = (N-1)*N*(N+1)/6
      DO 330 I=1,M
         DO 320 J=1,I
            SRCC(I,J) = 1.0E0
            IF (I.EQ.J) GO TO 320
            K1 = 2.0E0*T(I) + 0.4E0
            K2 = 2.0E0*T(J) + 0.4E0
            SRCC(I,J) = FPLM
            IF ((INT(B)-K1.LE.0) .OR. (INT(B)-K2.LE.0)) GO TO 320
            SUM = 0.0E0
            DO 310 K=1,N
               ZZ = RANK(K,I) - RANK(K,J)
               SUM = SUM + ZZ*ZZ
  310       CONTINUE
            ZZ = (B - 2.0E0*T(I))*(B - 2.0E0*T(J))
            IF (ZZ.GT.0.0E0) SRCC(I,J) = (B-SUM-T(I)-T(J))/SQRT(ZZ)
  320    CONTINUE
  330 CONTINUE
C
C     PRINT SPEARMAN RANK CORRELATIONS COEFFICIENTS
C
      WRITE (IPRT,1050)
      CALL MATPRT(SRCC, SRCC, M, IPRT, 0, 1, M)
C
      IF (N.GT.3) GO TO 340
      WRITE (IPRT,1060)
      RETURN
C
C     COMPUTE THE SIGNIFICANCE LEVELS OF THE QUADRATIC FIT OVER THE
C     LINEAR FIT.
C
C     THESE CALCULATIONS MAY PRODUCE VARIABLE RESULTS IN VARYING
C     MACHINE/COMPILATION ENVIRONMENTS, IN CASES IN WHICH THE
C     YM MATRIX IS NEAR SINGULAR (ESSENTIALLY SINGULAR BUT THE
C     SINGULARITY IS UNDETECTED BY THE CODE).  THE OBSERVED SYMPTOMS
C     ARE ALTERNATION BETWEEN QF VALUES OF 0.0E0 (FIRST F = LINE
C     PRODUCES ZERO) AND 1.0E0 (FIRST F = LINE PRODUCES APPROX.
C     ZERO, AND NUMERATOR IN SECOND F = LINE IS NONZERO).
C
  340 FN3 = N-3
      DO 410 J=1,M
         DO 400 I=1,M
            IF (I.NE.J) GO TO 350
            QF(I,J) = 1.0E0
            GO TO 400
  350       SQSUM = 0.0E0
            DO 360 K=1,N
              QUAD(K,1) = 1.0E0
               QUAD(K,2) = YM(K,J)
               QUAD(K,3) = YM(K,J)*YM(K,J)
               SQSUM = SQSUM + YM(K,I)*YM(K,I)
               WRK(K) = YM(K,I)
  360       CONTINUE
            CALL MGS(QUAD, WRK, N, 3, XX, C, D, RR, 3, N, IER)
            IF (IER.EQ.0) GO TO 370
            WRITE (IPRT,1090)
            GO TO 420
  370       DO 380 K=1,3
               C(K) = C(K)*SQRT(D(K))
  380       CONTINUE
            F = (SQSUM-C(1)*C(1)-C(2)*C(2)-C(3)*C(3))
            QF(I,J) = 0.0E0
            IF (F.EQ.0.0E0) GO TO 400
            F = (C(3)*C(3)*FN3)/F
            QF(I,J) = 1.0E0
            IF (F.GT.0.0E0) QF(I,J) = 1.0E0 - CDFF(F,1.0E0,FN3)
  400    CONTINUE
  410 CONTINUE
C
C     PRINT THE QUADRATIC FIT MATRIX
C
      J = 2
      K = 1
      I = N - 3
      WRITE (IPRT,1070) I, QF(J,K), J, K
      CALL MATPRT(QF, QF, M, IPRT, 1, 1, M)
C
C     COMPUTE CONFIDENCE LIMITS FOR SIMPLE CORRELATION COEFFICIENTS
C
  420 F = SQRT(FN3)
      HL1 = 2.5758293E0/F
      HL2 = 1.9599640E0/F
      DO 520 J=1,M
         DO 510 I=1,M
            IF (I.NE.J) GO TO 430
            CIUP(I,J) = 99.0E0
            CILO(I,J) = 95.0E0
            GO TO 510
  430       IF (I.LT.J) GO TO 470
C
C           COMPUTE 95 PERCENT INTERVALS.
C
            IF (SC(I,J).GE.1.0E0) GO TO 440
            IF (SC(I,J).GT.-1.0E0) GO TO 450
            Z = -1.0E0
            GO TO 460
  440       Z = 1.0E0
            GO TO 460
  450       Z = 0.5E0*LOG((1.0E0+SC(I,J))/(1.0E0-SC(I,J)))
  460       CIUP(I,J) = MIN(TANH(Z+HL2),1.0E0)
            CILO(I,J) = MAX(TANH(Z-HL2),-1.0E0)
            GO TO 510
C
C           COMPUTE 99 PERCENT INTERVALS.
C
  470       IF (SC(J,I).GE.1.0E0) GO TO 480
            IF (SC(J,I).GT.-1.0E0) GO TO 490
            Z = -1.0E0
            GO TO 500
  480       Z = 1.0E0
            GO TO 500
  490       Z = 0.5E0*LOG((1.0E0+SC(J,I))/(1.0E0-SC(J,I)))
  500       CIUP(I,J) = MIN(TANH(Z+HL1),1.0E0)
            CILO(I,J) = MAX(TANH(Z-HL1),-1.0E0)
  510    CONTINUE
  520 CONTINUE
C
C     PRINT CONFIDENCE LIMITS
C
      WRITE (IPRT,1080)
      CALL MATPRT(CIUP, CILO, M, IPRT, 1, 2, M)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/ 46H COMPUTATION STOPPED DUE TO SINGULAR OR ILL-CO,
     +   28HNDITIONED COVARIANCE MATRIX.)
 1010 FORMAT (//42H THE PARTIAL CORRELATION COEFFICIENTS (AND, 6H SIGNI,
     +   50HFICANCE LEVELS) ARE NOT PRINTED OR DEFINED BECAUSE/6H EITHE,
     +   52HR THE NUMBER OF VECTORS BEING COMPARED IS TWO OR THE,
     +   59H NUMBER OF MEASUREMENTS IS LESS THAN OR EQUAL TO THE NUMBER/
     +   27H OF VECTORS BEING COMPARED.)
 1020 FORMAT (// 44H SIGNIFICANCE LEVELS OF SIMPLE CORRELATION C,
     +   32HOEFFICIENTS (ASSUMING NORMALITY))
 1030 FORMAT (// 38H PARTIAL CORRELATION COEFFICIENTS WITH, I3,
     +   26H REMAINING VARIABLES FIXED)
 1040 FORMAT (// 44H SIGNIFICANCE LEVELS OF PARTIAL CORRELATION ,
     +   33HCOEFFICIENTS (ASSUMING NORMALITY))
 1050 FORMAT (// 44H SPEARMAN RANK CORRELATION COEFFICIENTS (ADJ,
     +   15HUSTED FOR TIES))
 1060 FORMAT (// 44H NONLINEARITY TEST AND APPROXIMATION OF CONF,
     +   39HIDENCE INTERVALS NOT DEFINED FOR N = 3.)
 1070 FORMAT (// 45H SIGNIFICANCE LEVEL OF QUADRATIC FIT OVER LIN,
     +   35HEAR FIT BASED ON F RATIO WITH 1 AND, I5, 15H DEGREES OF FRE,
     +   4HEDOM/14H (FOR EXAMPLE,, F7.4, 19H IS THE SIGNIFICANC,
     +   41HE LEVEL OF THE QUADRATIC TERM WHEN COLUMN, I3, 9H IS FITTE,
     +   11HD TO COLUMN, I3, ')')
 1080 FORMAT (// 44H CONFIDENCE INTERVALS FOR SIMPLE CORRELATION,
     +   43H COEFFICIENTS (USING FISHER TRANSFORMATION)/' 95 PER C',
     +   59HENT LIMITS BELOW DIAGONAL, 99 PER CENT LIMITS ABOVE DIAGONA,
     +   'L')
 1090 FORMAT (/ 46H SIGNIFICANCE LEVELS OF QUADRATIC FIT OVER LIN,
     +   30HEAR FIT HAVE NOT BEEN COMPUTED/' DUE TO SINGULARITY IN',
     +   32H DESIGN MATRIX. CHECK YOUR DATA.)
      END
*CORRS
      SUBROUTINE CORRS(YM, N, M, IYM, LDSTAK, NPRT, VCV, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR THE CORRELATION FAMILY.
C     IT IS THE LONG CALL FORM.
C     THIS ROUTINE CALLS CORRER TO CHECK FOR ERRORS IN THE PARAMETERS.
C     IF THERE ARE NO PROBLEMS IT THEN ALLOCATES SPACE IN CSTAK
C     FOR THE VECTORS NEEDED AND CALLS THE MAIN ROUTINE, CORRMN, TO DO
C     THE CORRELATION ANALYSIS.
C
C     WRITTEN BY -
C        LINDA L. MITCHELL
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IVCV,IYM,LDSTAK,M,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   VCV(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   AVG,CILO,CIUP,ICOR,IFP,IPRT,IWRK,LIWRK,LWRK,NALL0,PC,QF,
     +   QUAD,RANK,SC,SCINV,SD,SLPC,SLSC,SRCC,T,WRK
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CORRER,CORRMN,IPRINT,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER AVG
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  AVERAGES OF YM
C     INTEGER CILO
C                  OCCUPIES THE SAME SPACE AS SLPC AND IS THE LOWER
C                  CONFIDENCE INTERVAL
C     INTEGER CIUP
C                  OCCUPIES THE SAME SPACE AS SLSC AND IS THE UPPER
C                  CONFIDENCE INTERVAL
C     DOUBLE PRECISION DSTAK(12)
C                  THE DOUBLE PRECISION VERSION OF
C                  THE /CSTAK/ WORK AREA.
C     INTEGER ICOR
C                  DETERMINES WHICH SUBROUTINE CALLED CORRMN
C                  IF =1, THEN CALLED BY CORR
C                     =2, THEN CALLED BY CORRS
C     INTEGER IERR
C                  A FLAG RETURNED TO THE USER INDICATING
C                  WHETHER  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 IFP
C                  AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3
C                  INDICATES SINGLE PRECISION AND IFP=4 INDICATES
C                  DOUBLE PRECISION.
C     INTEGER IPRT
C                  LOGICAL OUTPUT UNIT
C     INTEGER ISTAK(12)
C                  THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IVCV
C                  THE DIMENSION OF VCV ASSIGNED IN THE USERS PROGRAM.
C     INTEGER IWRK
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  INTEGER WORK VECTOR.
C     INTEGER IYM
C                  ROW DIMENSION OF YM SPECIFIED IN THE USERS PROGRAM.
C     INTEGER LDSTAK
C                  SIZE OF WORK AREA ALLOCATED IN THE USERS PROGRAM
C     INTEGER LIWRK
C                  THE LENGTH OF THE INTEGER WORK VECTOR.
C     INTEGER LWRK
C                  THE LENGTH OF THE REAL WORK VECTOR.
C     INTEGER M
C                  THE NUMBER OF VARIABLES
C     INTEGER N
C                  THE NUMBER OF OBSERVATIONS
C     INTEGER NALL0
C                  THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE
C                  TIME THAT THIS ROUTINE WAS CALLED.
C     CHARACTER*1 NMSUB(6)
C                  THE SUBROUTINE NAME
C     INTEGER NPRT
C                  THE VARIABLE CONTROLLING THE AUTOMATIC PRINTOUT
C                  NPRT = 0 PRINTOUT IS SUPRESSED
C                  OTHERWISE THE PRINTOUT IS PROVIDED.
C     INTEGER PC
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  THE PARTIAL CORRELATION COEFFICIENTS MATRIX
C     INTEGER QF
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  QUADRATIC FIT MATRIX
C     INTEGER QUAD
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  REAL  QUAD FIT
C     INTEGER RANK
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  MATRIX CONTAINING THE RANKS OF YM
C     REAL RSTAK(12)
C                  THE REAL VERSION OF
C                  THE /CSTAK/ WORK AREA.
C     INTEGER SC
C                  THE STARTING LOCATION IN THE WORK AREA FOR THE
C                  THE SIMPLE CORRELATION COEFFICIENTS MATRIX
C     INTEGER SCINV
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  INVERSE MATRIX OF VCV
C     INTEGER SD
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  STANDARD DEVIATIONS VECTOR
C     INTEGER SLPC
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  SIGNIFICANCE LEVELS FOR PC
C     INTEGER SLSC
C                  THE STARTING LOCATION IN THE WORK AREA OF THE
C                  SIGNIFICANCE LEVELS FOR SC
C     INTEGER SRCC
C                  STARTING LOCATION IN THE WORK AREA FOR THE SPEAR-
C                  MAN RANK COEFFICIENTS
C     INTEGER T
C                  STARTING LOCATION IN THE WORK AREA
C                  FOR THE WORK VECTOR T
C     REAL VCV(IVCV,M)
C                  THE VARIANCE COVARIANCE MATRIX
C     INTEGER WRK
C                  THE STARTING LOCATION IN THE WORK AREA FOR
C                  WORK SPACE
C     REAL YM(IYM,M)
C                  THE OBSERVATION MATRIX
C
C
C     SET UP NAME ARRAY
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'C',      'O',      'R',      'R',      'S',      ' '/
C
C     SET UP FRAMEWORK VARIABLES FOR NUMBER TYPES
C
      IFP = 3
C
C     SET THE CALLER FLAG, THIS IS CORRS
C
      ICOR = 2
C
C     CHECK FOR ERRORS IN PARAMETERS
C
      CALL CORRER(NMSUB, M, N, IYM, IVCV, LDSTAK, ICOR, NPRT)
C
C     IF THERE IS AN ERROR RETURN TO THE CALLERS ROUTINE
C
      IF (IERR.EQ.0) GO TO 10
C
C     PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     INITIALIZE THE STACK
C
   10 CALL STKSET (LDSTAK, 4)
      NALL0 = STKST(1)
C
C     ALLOCATE SPACE IN DSTAK FOR MATRICES
C
      LIWRK = MAX(N,M)
      LWRK = LIWRK
C
      WRK = STKGET(LWRK,IFP)
C
      IF (NPRT.EQ.0) THEN
         IWRK = WRK
         T = WRK
         RANK = WRK
         SC = WRK
         SCINV = WRK
         SLSC = WRK
         PC = WRK
         SLPC = WRK
         QUAD = WRK
         QF = WRK
      ELSE
         IWRK = STKGET(LIWRK,2)
         T = STKGET(M,IFP)
         RANK = STKGET(N*M,IFP)
         SC = STKGET(M*M,IFP)
         SCINV = STKGET(M*M,IFP)
         SLSC = STKGET(M*M,IFP)
         PC = STKGET(M*M,IFP)
         SLPC = STKGET(M*M,IFP)
         QUAD = STKGET(3*N,IFP)
         QF = STKGET(M*M,IFP)
      END IF
C
C     THE FOLLOWING VARIABLES HAVE BEEN INDIRECTLY EQUIVALENCED-
C
      CIUP = SLSC
      CILO = SLPC
      AVG = WRK
      SD = WRK
      SRCC = SCINV
C
      CALL CORRMN(YM, N, M, IYM, RSTAK(AVG), RSTAK(SD), RSTAK(T),
     +   RSTAK(RANK), RSTAK(SC), RSTAK(PC), RSTAK(SCINV), ISTAK(IWRK),
     +   RSTAK(WRK), RSTAK(SLSC), RSTAK(SLPC), RSTAK(SRCC),
     +   RSTAK(QUAD), RSTAK(CIUP), RSTAK(CILO), RSTAK(QF),
     +   NPRT, VCV, IVCV, LIWRK, LWRK)
C
C     RETURN AREA TO WORK
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL CORRS (YM, N, M, IYM, LDSTAK, NPRT, VCV, IVCV)')
      END
*CORRXP
      SUBROUTINE CORRXP(M, VCV, IVCV, IPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     PRINT STORED OUTPUT RETURNED FROM CORRS
C
C     WRITTEN BY -
C        LINDA MITCHELL
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IPRT,IVCV,M
C
C  ARRAY ARGUMENTS
      REAL
     +   VCV(*)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL MATPRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE LOGICAL OUTPUT NUMBER
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV
C     INTEGER M
C        THE NUMBER OF VARIABLES IN THE ANALYSIS
C     REAL VCV(IVCV,M)
C        ARRAYS TO BE PRINTED
C
      IF (IVCV.GE.M) THEN
         WRITE (IPRT,1000)
         WRITE (IPRT,1010)
         CALL MATPRT(VCV, VCV, M, IPRT, 1, 1, IVCV)
      END IF
C
C     FORMAT STATEMENTS
C
      RETURN
 1000 FORMAT (/ 20H STORAGE FROM CORRS.)
 1010 FORMAT (40H STORAGE FROM VARIANCE-COVARIANCE MATRIX)
      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
      REAL
     +   D(P),J(NN,P),R(N),V(1),X(P)
      INTEGER
     +   IV(1)
C
C  LOCAL SCALARS
      REAL
     +   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,LSQRT,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     REAL 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     REAL DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO
C
C/
C  ***  EXTERNAL SUBROUTINES  ***
C
C     EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRT, 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 LSQRT.... 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
      DATA HALF/0.5E0/, NEGPT5/-0.5E0/, ONE/1.0E0/, TWO/2.0E0/,
     +     ZERO/0.0E0/
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 LSQRT(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
*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
      REAL
     +   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     REAL X(LX)
C        THE MATRIX TO BE COPIED FROM.
C     REAL Y(IY,M)
C        THE MATRIX TO BE COPIED TO.
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
*CPYMSS
      SUBROUTINE CPYMSS (N, M, X, IX, Y, IY)
C
C     LATEST REVISION  -  03/15/90  (JRD
C
C     THIS ROUTINE COPIES THE N BY M ELEMENTS OF MATRIX X TO
C     MATRIX Y.
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
     +   IX,IY,M,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(IX,*),Y(IY,*)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER IX
C        THE FIRST DIMENSION OF THE MATRIX X.
C     INTEGER IY
C        THE FIRST DIMENSION OF THE MATRIX Y.
C     INTEGER J
C        AN INDEX VALUE.
C     INTEGER M
C        THE NUMBER OF COLUMNS OF DATA TO BE COPIED FROM MATRIX X.
C     INTEGER N
C        THE NUMBER OF ROWS OF DATA TO BE COPIED FROM MATRIX X.
C     REAL X(IX,M)
C        THE MATRIX TO BE COPIED FROM.
C     REAL Y(IY,M)
C        THE MATRIX TO BE COPIED TO.
C
C
      DO 20 J = 1, M
         DO 10 I = 1, N
            Y(I,J) = X(I,J)
   10    CONTINUE
   20 CONTINUE
C
      RETURN
C
      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
      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
*CSEVL
      REAL FUNCTION CSEVL (X, CS, N)
C APRIL 1977 VERSION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C EVALUATE THE N-TERM CHEBYSHEV SERIES CS AT X.  ADAPTED FROM
C R. BROUCKE, ALGORITHM 446, C.A.C.M., 16, 254 (1973).  ALSO SEE FOX
C AND PARKER, CHEBYSHEV POLYS IN NUMERICAL ANALYSIS, OXFORD PRESS, P.56.
C
C             INPUT ARGUMENTS --
C X      VALUE AT WHICH THE SERIES IS TO BE EVALUATED.
C CS     ARRAY OF N TERMS OF A CHEBYSHEV SERIES.  IN EVAL-
C        UATING CS, ONLY HALF THE FIRST COEF IS SUMMED.
C N      NUMBER OF TERMS IN ARRAY CS.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
      INTEGER N
C
C  ARRAY ARGUMENTS
      REAL CS(N)
C
C  LOCAL SCALARS
      REAL B0,B1,B2,TWOX
      INTEGER I,NI
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C
      IF (N.LT.1) CALL XERROR ('CSEVL   NUMBER OF TERMS LE 0', 28, 2,2)
      IF (N.GT.1000) CALL XERROR ('CSEVL   NUMBER OF TERMS GT 1000',
     1  31, 3, 2)
      IF (X.LT.(-1.0) .OR. X.GT.1.0) CALL XERROR (
     1  'CSEVL   X OUTSIDE (-1,+1)', 25, 1, 1)
C
      B0 = 0.0
      B1 = 0.0
      B2 = 0.0
      TWOX = 2.0*X
      DO 10 I=1,N
        B2 = B1
        B1 = B0
        NI = N + 1 - I
        B0 = TWOX*B1 - B2 + CS(NI)
 10   CONTINUE
C
      CSEVL = 0.5 * (B0-B2)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION D9GMIT(A,X,ALGAP1,SGNGAM,ALX)
C***BEGIN PROLOGUE  D9GMIT
C***DATE WRITTEN   770701   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C7E
C***KEYWORDS  COMPLEMENTARY,COMPLEMENTARY INCOMPLETE GAMMA FUNCTION,
C             DOUBLE PRECISION,GAMMA,GAMMA FUNCTION,SPECIAL FUNCTON,
C             TRICOMI
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  COMPUTES D.P. TRICOMI-S INCOMPLETE GAMMA FUNCTION FOR
C            SMALL X.
C***DESCRIPTION
C
C COMPUTE TRICOMI'S INCOMPLETE GAMMA FUNCTION FOR SMALL X.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH,DLNGAM,XERROR
C***END PROLOGUE  D9GMIT
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION A,ALGAP1,ALX,SGNGAM,X
C
C  LOCAL SCALARS
      DOUBLE PRECISION AE,AEPS,ALG2,ALGS,BOT,EPS,FK,S,SGNG2,T,TE
      INTEGER K,M,MA
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,DLNGAM
      EXTERNAL D1MACH,DLNGAM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DBLE,DSIGN,EXP,FLOAT,LOG
C
      DATA EPS, BOT / 2*0.D0 /
C***FIRST EXECUTABLE STATEMENT  D9GMIT
      IF (EPS.NE.0.D0) GO TO 10
      EPS = 0.5D0*D1MACH(3)
      BOT = LOG (D1MACH(1))
C
 10   IF (X.LE.0.D0) CALL XERROR ( 'D9GMIT  X SHOULD BE GT 0', 24, 1, 2)
C
      MA = A + 0.5D0
      IF (A.LT.0.D0) MA = A - 0.5D0
      AEPS = A - DBLE(FLOAT(MA))
C
      AE = A
      IF (A.LT.(-0.5D0)) AE = AEPS
C
      T = 1.D0
      TE = AE
      S = T
      DO 20 K=1,200
        FK = K
        TE = -X*TE/FK
        T = TE/(AE+FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 30
 20   CONTINUE
      CALL XERROR ( 'D9GMIT  NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SER
     1IES', 54, 2, 2)
C
 30   IF (A.GE.(-0.5D0)) THEN
         ALGS = -ALGAP1 + LOG(S)
      ELSE
         ALGS = -DLNGAM(1.D0+AEPS) + LOG(S)
         S = 1.0D0
         M = -MA - 1
         IF (M.EQ.0) GO TO 50
         T = 1.0D0
         DO 40 K=1,M
            T = X*T/(AEPS-DBLE(FLOAT(M+1-K)))
            S = S + T
            IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40      CONTINUE
C
 50      D9GMIT = 0.0D0
         ALGS = -DBLE(FLOAT(MA))*LOG(X) + ALGS
         IF (S.NE.0.0D0 .AND. AEPS.NE.0.0D0) THEN
            SGNG2 = SGNGAM * DSIGN (1.0D0, S)
            ALG2 = -X - ALGAP1 + LOG(ABS(S))
C
            IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2)
            IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS)
            RETURN
         END IF
      END IF
C
      D9GMIT = EXP (ALGS)
      RETURN
C
      END
*D9LGIC
      DOUBLE PRECISION FUNCTION D9LGIC(A,X,ALX)
C***BEGIN PROLOGUE  D9LGIC
C***DATE WRITTEN   770701   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C7E
C***KEYWORDS  DOUBLE PRECISION,GAMMA,INCOMPLETE GAMMA FUNCTION,
C             LOGARITHM INCOMPLETE GAMMA FUNCTION,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  COMPUTES THE D.P. LOG INCOMPLETE GAMMA FUNCTION FOR LARGE X
C            AND FOR A .LE. X.
C***DESCRIPTION
C
C COMPUTE THE LOG COMPLEMENTARY INCOMPLETE GAMMA FUNCTION FOR LARGE X
C AND FOR A .LE. X.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH,XERROR
C***END PROLOGUE  D9LGIC
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION A,ALX,X
C
C  LOCAL SCALARS
      DOUBLE PRECISION EPS,FK,P,R,S,T,XMA,XPA
      INTEGER K
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH
      EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG
C
      DATA EPS / 0.D0 /
C***FIRST EXECUTABLE STATEMENT  D9LGIC
      IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3)
C
      XPA = X + 1.0D0 - A
      XMA = X - 1.D0 - A
C
      R = 0.D0
      P = 1.D0
      S = P
      DO 10 K=1,300
        FK = K
        T = FK*(A-FK)*(1.D0+R)
        R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 20
 10   CONTINUE
      CALL XERROR ( 'D9LGIC  NO CONVERGENCE IN 300 TERMS OF CONTINUED FR
     1ACTION', 57, 1, 2)
C
 20   D9LGIC = A*ALX - X + LOG(S/XPA)
C
      RETURN
      END
*D9LGIT
      DOUBLE PRECISION FUNCTION D9LGIT(A,X,ALGAP1)
C***BEGIN PROLOGUE  D9LGIT
C***DATE WRITTEN   770701   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C7E
C***KEYWORDS  DOUBLE PRECISION,GAMMA,INCOMPLETE GAMMA FUNCTION,
C             LOGARITHM,SPECIAL FUNCTION,TRICOMI
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  COMPUTES  THE LOG OF TRICOMI'S INCOMPLETE GAMMA FUNCTION
C            WITH PERRON'S CONTINUED FRACTION FOR LARGE X AND A .GE. X.
C***DESCRIPTION
C
C COMPUTE THE LOG OF TRICOMI'S INCOMPLETE GAMMA FUNCTION WITH PERRON'S
C CONTINUED FRACTION FOR LARGE X AND FOR A .GE. X.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH,XERROR
C***END PROLOGUE  D9LGIT
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION A,ALGAP1,X
C
C  LOCAL SCALARS
      DOUBLE PRECISION A1X,AX,EPS,FK,HSTAR,P,R,S,SQEPS,T
      INTEGER K
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH
      EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DSQRT,LOG
C
      DATA EPS, SQEPS / 2*0.D0 /
C***FIRST EXECUTABLE STATEMENT  D9LGIT
      IF (EPS.NE.0.D0) GO TO 10
      EPS = 0.5D0*D1MACH(3)
      SQEPS = DSQRT (D1MACH(4))
C
 10   IF (X.LE.0.D0 .OR. A.LT.X) CALL XERROR ( 'D9LGIT  X SHOULD BE GT 0
     1.0 AND LE A', 35, 2, 2)
C
      AX = A + X
      A1X = AX + 1.0D0
      R = 0.D0
      P = 1.D0
      S = P
      DO 20 K=1,200
        FK = K
        T = (A+FK)*X*(1.D0+R)
        R = T/((AX+FK)*(A1X+FK)-T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 30
 20   CONTINUE
      CALL XERROR ( 'D9LGIT  NO CONVERGENCE IN 200 TERMS OF CONTINUED FR
     1ACTION', 57, 3, 2)
C
 30   HSTAR = 1.0D0 - X*S/A1X
      IF (HSTAR.LT.SQEPS) CALL XERROR ( 'D9LGIT  RESULT LESS THAN HALF P
     1RECISION', 39, 1, 1)
C
      D9LGIT = -X - ALGAP1 - LOG(HSTAR)
      RETURN
C
      END
*D9LGMC
      DOUBLE PRECISION FUNCTION D9LGMC (X)
C AUGUST 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C COMPUTE THE LOG GAMMA CORRECTION FACTOR FOR X .GE. 10. SO THAT
C LOG (DGAMMA(X)) = LOG(DSQRT(2*PI)) + (X-.5)*LOG(X) - X + D9LGMC(X)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
C
C  LOCAL SCALARS
      DOUBLE PRECISION XBIG,XMAX
      INTEGER NALGM
C
C  LOCAL ARRAYS
      DOUBLE PRECISION ALGMCS(15)
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,DCSEVL
      INTEGER INITDS
      EXTERNAL D1MACH,DCSEVL,INITDS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC DSQRT,EXP,LOG,MIN,SNGL
C
C
C SERIES FOR ALGM       ON THE INTERVAL  0.          TO  1.00000E-02
C                                        WITH WEIGHTED ERROR   1.28E-31
C                                         LOG WEIGHTED ERROR  30.89
C                               SIGNIFICANT FIGURES REQUIRED  29.81
C                                    DECIMAL PLACES REQUIRED  31.48
C
      DATA ALGMCS(  1) / +.1666389480 4518632472 0572965082 2 D+0      /
      DATA ALGMCS(  2) / -.1384948176 0675638407 3298605913 5 D-4      /
      DATA ALGMCS(  3) / +.9810825646 9247294261 5717154748 7 D-8      /
      DATA ALGMCS(  4) / -.1809129475 5724941942 6330626671 9 D-10     /
      DATA ALGMCS(  5) / +.6221098041 8926052271 2601554341 6 D-13     /
      DATA ALGMCS(  6) / -.3399615005 4177219443 0333059966 6 D-15     /
      DATA ALGMCS(  7) / +.2683181998 4826987489 5753884666 6 D-17     /
      DATA ALGMCS(  8) / -.2868042435 3346432841 4462239999 9 D-19     /
      DATA ALGMCS(  9) / +.3962837061 0464348036 7930666666 6 D-21     /
      DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23     /
      DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24     /
      DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26     /
      DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27     /
      DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29     /
      DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30     /
C
      DATA NALGM, XBIG, XMAX / 0, 2*0.D0 /
C
      IF (NALGM.NE.0) GO TO 10
      NALGM = INITDS (ALGMCS, 15, SNGL(D1MACH(3)) )
      XBIG = 1.0D0/DSQRT(D1MACH(3))
      XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1))))
C
 10   IF (X.LT.10.D0) CALL XERROR ('D9LGMC  X MUST BE GE 10', 23, 1, 2)
      IF (X.GE.XMAX) GO TO 20
C
      D9LGMC = 1.D0/(12.D0*X)
      IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS,
     1  NALGM) / X
      RETURN
C
 20   D9LGMC = 0.D0
      CALL XERROR ('D9LGMC  X SO BIG D9LGMC UNDERFLOWS', 34, 2, 1)
      RETURN
C
      END
*DBETAI
      DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C BASED ON BOSTEN AND BATTISTE, REMARK ON ALGORITHM 179, COMM. ACM,
C V 17, P 156, (1974).
C
C             INPUT ARGUMENTS --
C X      UPPER LIMIT OF INTEGRATION.  X MUST BE IN (0,1) INCLUSIVE.
C P      FIRST BETA DISTRIBUTION PARAMETER.  P MUST BE GT 0.0.
C Q      SECOND BETA DISTRIBUTION PARAMETER.  Q MUST BE GT 0.0.
C BETAI  THE INCOMPLETE BETA FUNCTION RATIO IS THE PROBABILITY THAT A
C        RANDOM VARIABLE FROM A BETA DISTRIBUTION HAVING PARAMETERS
C        P AND Q WILL BE LESS THAN OR EQUAL TO X.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION PIN,QIN,X
C
C  LOCAL SCALARS
      DOUBLE PRECISION ALNEPS,ALNSML,C,EPS,FAC1,FAC2,FINSUM,P,PS,Q,SML,
     +   TERM,XB,Y
      REAL P1
      INTEGER I,IB,N
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,DLBETA
      EXTERNAL D1MACH,DLBETA
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DBLE,EXP,FLOAT,INT,LOG,MAX,MIN,SNGL
C
      DATA             EPS, ALNEPS, SML, ALNSML / 4*0.0D0 /
C
      IF (EPS.NE.0.0D0) GO TO 10
      EPS = D1MACH(3)
      ALNEPS = LOG (EPS)
      SML = D1MACH(1)
      ALNSML = LOG (SML)
C
 10   IF (X.LT.0.D0 .OR. X.GT.1.D0) CALL XERROR (
     1  'DBETAI  X IS NOT IN THE RANGE (0,1)', 35, 1, 2)
      IF (PIN.LE.0.D0 .OR. QIN.LE.0.D0) CALL XERROR (
     1  'DBETAI  P AND/OR Q IS LE ZERO', 29, 2, 2)
C
      Y = X
      P = PIN
      Q = QIN
      IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20
      IF (X.LT.0.2D0) GO TO 20
      Y = 1.0D0 - Y
      P = QIN
      Q = PIN
C
 20   IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80
C
C EVALUATE THE INFINITE SUM FIRST.  TERM WILL EQUAL
C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) .
C
      PS = Q - INT(Q)
      IF (PS.EQ.0.D0) PS = 1.0D0
      XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P)
      DBETAI = 0.0D0
      IF (XB.GE.ALNSML) THEN
         DBETAI = EXP(XB)
         FAC2 = 1.0
         IF (PS.NE.1.0D0) THEN
            FAC1 = 1.0
            N = MAX(ALNEPS/LOG(Y), 4.0D0)
            DO 30 I=1,N
               IF ((I-PS.EQ.0.0D0) .OR. (FAC1.EQ.0.0D0)) THEN
                  FAC1 = 0.0D0
               ELSE
                  IF (LOG(ABS(FAC1)) + LOG(ABS(I-PS)) + LOG(Y) -
     +                LOG(DBLE(I)) .LT. ALNSML) THEN
                     FAC1 = 0.0D0
                  ELSE
                     FAC1 = FAC1 * (I-PS)*Y/I
                  END IF
               END IF
               FAC2 = FAC2 + FAC1*P/(P+I)
 30         CONTINUE
         END IF
         DBETAI = DBETAI*FAC2
      END IF
C
C NOW EVALUATE THE FINITE SUM, MAYBE.
C
      IF (Q.LE.1.0D0) GO TO 70
C
      XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q)
      IB = MAX(SNGL(XB/ALNSML), 0.0)
      TERM = EXP (XB - DBLE(FLOAT(IB))*ALNSML )
      C = 1.0D0/(1.D0-Y)
      P1 = Q*C/(P+Q-1.D0)
C
      FINSUM = 0.0D0
      N = Q
      IF (Q.EQ.DBLE(FLOAT(N))) N = N - 1
      DO 50 I=1,N
        IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
        IF (Q-I+1.0D0 .EQ. 0.0D0) THEN
          TERM = 0.0D0
        ELSE
          IF (LOG(ABS(Q-I+1.0D0)) + LOG(ABS(C)) + LOG(ABS(TERM)) -
     +        LOG(ABS(P+Q-I)) .LT. ALNSML) THEN
            TERM = 0.0D0
          ELSE
            TERM = (Q-I+1.0D0)*C*TERM/(P+Q-I)
          END IF
        END IF
C
        IF (TERM.GT.1.0D0) IB = IB - 1
        IF (TERM.GT.1.0D0) TERM = TERM*SML
C
        IF (IB.EQ.0) FINSUM = FINSUM + TERM
 50   CONTINUE
C
 60   DBETAI = DBETAI + FINSUM
 70   IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI
      DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0)
      RETURN
C
 80   DBETAI = 0.0D0
      XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q)
      IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB)
      IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI
C
      RETURN
      END
*DCKCNT
      SUBROUTINE DCKCNT(XM, N, M, IXM, MDL, DRV, PAR, NPAR, NETA, NTAU,
     +   SCALE, LSCALE, NROW, NPRT, HDR, PAGE, WIDE, ISUBHD, HLFRPT,
     +   PRTFXD, IFIXED, LIFIXD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CONTROLS THE DERIVATIVE CHECKING 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
      INTEGER
     +   ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT,NROW,NTAU
      LOGICAL
     +   HLFRPT,PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),SCALE(LSCALE),XM(IXM,M)
      INTEGER
     +   IFIXED(LIFIXD)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,HDR,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   D,ETA,FPLRS,PV,SCL,TAU
      INTEGER
     +   DTEMP,IFIXD,IFP,INDXD,INDXPV,J,LMSG,MSG,NALL0,NDD,NDGT1,
     +   NDGT2,NROWU,PARTMP,PVTEMP
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      INTEGER
     +   STKGET,STKST
      EXTERNAL R1MACH,STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CPYVII,DCKMN,DCKOUT,ETAMDL,SETIV,SETROW,STKCLR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL D
C        THE SCALAR IN WHICH ROW   NROWU   OF THE DERIVATIVE
C        MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER
C        IS STORED.
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        ANALYTIC DERIVATIVES (JACOBIAN MATRIX) OF THE MODEL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER DTEMP
C        THE STARTING LOCATION IN THE WORK AREA IN WHICH
C        THE ARRAY IN WHICH THE ANALYTIC DERIVATIVES WITH
C        RESPECT TO EACH UNKNOWN PARAMETER ARE STORED.
C     REAL ETA
C        THE RELATIVE NOISE IN THE MODEL.
C     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     EXTERNAL HDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING
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 .EQ. 1, ERRORS HAVE BEEN 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     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
C        IFIXED(I).EQ.0, 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 INDXD, INDXPV
C        THE INDEX IN THE WORK AREA OF
C        THE LOCATION OF THE VALUE OF THE
C        DERIVATIVE WITH RESPECT TO THE JTH PARAMETER AT ROW   NROWU
C        AND OF THE LOCATION OF THE PREDICTED VALUE FROM THE MODEL FOR R
C        ROW   NROWU   .
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 BY
C        ROUTINE HDR.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER LIFIXD
C        THE LENGTH OF THE VECTOR IFIXED.
C     INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
C     INTEGER LSCALE
C        THE LENGTH 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 MSG
C        THE STARTING LOCATION IN THE WORK AREA OF
C        AN ARRAY USED TO STORE MESSAGE PARAMETERS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS ON ENTRY.
C     INTEGER NDD
C        THE NUMBER OF DECIMAL DIGITS CARRIED FOR A SINGLE
C        PRECISION REAL 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 NDGT2
C        THE ACTUAL NUMBER OF DIGITS OF AGREEMENT USED, EITHER
C        SET TO THE USER SUPPLIED VALUE OF NTAU, OR COMPUTED
C        FROM NDGT1.
C     INTEGER NETA
C        THE USER SUPPLIED NUMBER OF RELIABLE DIGITS IN THE MODEL.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
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     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     INTEGER NTAU
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES.
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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
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     REAL PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
C     INTEGER PVTEMP
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C     REAL SCL
C        THE ACTUAL TYPICAL SIZE USED.
C     REAL TAU
C        THE AGREEMENT TOLERANCE.
C     LOGICAL WIDE
C       THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        FULL WIDTH (TRUE) OR NOT (FALSE).
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
      NALL0 = STKST(1)
C
      FPLRS = R1MACH(4)
C
C     SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS
C
      CALL SETROW(NROW, XM, N, M, IXM, NROWU)
C
C     SUBDIVIDE WORK AREA
C
      IFP = 3
C
      LMSG = NPAR + 1
C
      IFIXD = STKGET(NPAR,2)
      MSG = STKGET(LMSG,2)
      DTEMP = STKGET(N*NPAR,IFP)
      PARTMP = STKGET(NPAR,IFP)
      PVTEMP = STKGET(N,IFP)
C
      IF (IERR.EQ.1) RETURN
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 = -LOG10(FPLRS)
C
      IF ((NETA.LT.2) .OR. (NETA.GT.NDD)) THEN
         CALL ETAMDL(MDL, PAR, NPAR, XM, N, M, IXM, ETA, NDGT1,
     +      RSTAK(PARTMP), RSTAK(PVTEMP), NROWU)
      ELSE
         ETA = 10.0E0**(-NETA)
         NDGT1 = NETA
      END IF
C
      IF ((NTAU.LT.1) .OR. (NTAU.GT.(NDGT1-1)/2)) THEN
         NDGT2 = (NDGT1+3)/4
      ELSE
         NDGT2 = NTAU
      END IF
C
      TAU = 10.0E0**(-NDGT2)
C
      INDXPV = PVTEMP + NROWU - 1
C
C     COMPUTE PREDICTED VALUE OF MODEL USING CURRENT PARAMETER
C     ESTIMATES, AND COMPUTE USER-SUPPLIED DERIVATIVE VALUES
C
      CALL MDL(PAR, NPAR, XM, N, M, IXM, RSTAK(PVTEMP))
      PV = RSTAK(INDXPV)
      CALL DRV(PAR, NPAR, XM, N, M, IXM, RSTAK(DTEMP))
C
      ISTAK(MSG) = 0
C
      DO 30 J=1,NPAR
C
         IF (SCALE(1).GT.0.0E0) THEN
            SCL = SCALE(J)
         ELSE
            SCL = PAR(J)
         END IF
         IF (SCL.EQ.0.0E0) SCL = 1.0E0
C
C     CALL ROUTINE TO CHECK USER SUPPLIED NUMERICAL DERIVATIVES
C     WITH RESPECT TO THE JTH PARAMETER.
C
         INDXD = DTEMP - 1 + N*(J-1) + NROWU
C
         D = RSTAK(INDXD)
         CALL DCKMN(J, D, PAR, SCL, NPAR, ETA, TAU, MDL, XM, N, NROWU,
     +      M, IXM, PV, RSTAK(PVTEMP), ISTAK(MSG), LMSG)
C
   30 CONTINUE
C
      IF (ISTAK(MSG).GE.1) IERR = ISTAK(MSG) + 1
C
C     PRINT RESULTS IF THEY ARE DESIRED
C
      HLFRPT = .FALSE.
C
      IF ((NPRT.NE.0) .OR. (IERR.NE.0)) THEN
         HLFRPT = .TRUE.
         CALL DCKOUT(XM,IXM,N,M,NROWU,NDGT1,NDGT2,NPAR,ISTAK(MSG),
     +      LMSG,PAR,SCALE,LSCALE,HDR,PAGE,WIDE,ISUBHD,PRTFXD,
     +      ISTAK(IFIXD))
      END IF
C
      CALL STKCLR(NALL0)
C
      RETURN
C
      END
*DCKCRV
      SUBROUTINE DCKCRV(J, D, PAR, NPAR, ETA, TAU, MDL, XM, N,
     +   NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX, PVPSTP, STP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER HIGH CURVATURE COULD BE THE CAUSE
C     OF THE DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC 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
      REAL
     +   D,ETA,FD,PARMX,PV,PVPSTP,STP,TAU
      INTEGER
     +   IXM,J,LMSG,M,N,NPAR,NROW
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PVTEMP(N),XM(IXM,M)
      INTEGER
     +   MSG(LMSG)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  LOCAL SCALARS
      REAL
     +   CURVE,FPLRS,PVMCRV,PVPCRV,STPCRV,TEMP,THIRD
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCKFPA
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SIGN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CURVE
C        A MEASURE OF THE CURVATURE IN THE MODEL.
C     REAL D
C        THE SCALAR IN WHICH ROW   NROW   OF THE DERIVATIVE
C        MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER
C        IS STORED.
C     REAL ETA
C        THE RELATIVE NOISE IN THE MODEL.
C     REAL FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER.
C     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C     INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
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 MSG(LMSG)
C        AN ARRAY USED TO STORE MESSAGE PARAMETERS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE.
C     REAL PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
C     REAL PVMCRV
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)-STPCRV.
C     REAL PVPCRV
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCRV.
C     REAL PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP.
C     REAL PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUES FROM THE MODEL.
C     REAL STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
C     REAL STPCRV
C        THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL.
C     REAL TAU
C        THE AGREEMENT TOLERANCE.
C     REAL TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     REAL THIRD
C        THE VALUE ONE THIRD.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
      FPLRS = R1MACH(4)
C
      THIRD = 1.0E0/3.0E0
C
      STPCRV = (ETA**THIRD*PARMX*SIGN(1.0E0,PAR(J))+PAR(J)) - PAR(J)
C
      TEMP = PAR(J)
      PAR(J) = TEMP + STPCRV
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP)
C
      PVPCRV = PVTEMP(NROW)
C
      PAR(J) = TEMP - STPCRV
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP)
      PAR(J) = TEMP
C
      PVMCRV = PVTEMP(NROW)
C
C     ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL WITH RESPECT TO
C     PAR(J)
C
      CURVE = ((PVPCRV+PVMCRV)-2*PV) / (STPCRV*STPCRV)
      CURVE = CURVE + (ETA ** THIRD) * (ABS(PVPCRV) +
     +   ABS(PVMCRV) + 2.0E0 * ABS(PV)) / (PARMX * PARMX)
C
C     COMPARE NUMERICAL AND ANALYTICAL DERIVATIVES USING A FUDGE
C     FACTOR OF 10.0E0.
C
      IF (ABS(CURVE*STP)*5.0E0.LT.ABS(FD-D)) THEN
C
C     CURVATURE CANNOT ACCOUNT FOR DISCREPANCY.
C     CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT.
C
         CALL DCKFPA(J,D,PAR,NPAR,ETA,TAU,MDL,XM,N,NROW,
     +      M,IXM,PV,PVTEMP,MSG,LMSG,FD,PARMX,STP,PVPSTP,CURVE)
C
      ELSE
C
C     HIGH CURVATURE COULD BE THE PROBLEM.  TRY A SMALLER STEP SIZE.
C     COMPUTE SMALLER STEPSIZE
C
         STP = (2.0E0*TAU*ABS(D)*SIGN(1.0E0,PAR(J))/ABS(CURVE)+PAR(J))
     +          - PAR(J)
C
         IF (ABS(STP).LE.FPLRS*ABS(PAR(J))) THEN
C
C     NEW STEP SIZE IS TOO SMALL TO USE.
C
            IF (MSG(1).EQ.0) MSG(1) = 1
            MSG(J+1) = 1
         ELSE
C
C     TRY NEW STEP SIZE
C
            TEMP = PAR(J)
            PAR(J) = TEMP + STP
            CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP)
            PAR(J) = TEMP
            PVPSTP = PVTEMP(NROW)
C
C     COMPUTE THE NEW NUMERICAL DERIVATIVE
C
            FD = (PVPSTP-PV)/STP
C
C     CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS NOT OK
C
            IF (ABS(FD-D).GT.2.0E0*TAU*ABS(D)) THEN
C
C     NUMERICAL DERIVATIVE COMPUTED USING NEW STEP SIZE DOES
C     NOT AGREE WITH ANALYTIC DERIVATIVE.
C
C     CHECK IF THE PROBLEM COULD BE THE FORWARD DIFFERENCE QUOTIENT
C     DERIVATIVE.
C     (FUDGE FACTOR IS 2)
C
               IF (ABS(STP*(FD-D)).GE.2.0E0*ETA*ABS(PV+PVPSTP)) THEN
C
C     FINITE PRECISION COULD NOT BE THE CULPRIT
C
                  MSG(1) = 2
                  MSG(J+1) = 2
               ELSE
C
C     FINITE PRECISION MAY BE THE CULPRIT
C
                  IF (MSG(1).EQ.0) MSG(1) = 1
                  MSG(J+1) = 1
               END IF
            END IF
         END IF
      END IF
      RETURN
C
      END
*DCKDRV
      SUBROUTINE DCKDRV (NMSUB, LDSTAK, XM, N, M, IXM, MDL,
     +   DRV, PAR, NPAR, NETA, NTAU, SCALE, LSCALE, NROW, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE IS THE DRIVER FOR THE DERIVATIVE CHECKING 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
      INTEGER
     +   IXM,LDSTAK,LSCALE,M,N,NETA,NPAR,NPRT,NROW,NTAU
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),SCALE(*),XM(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   ISUBHD,LIFIXD
      LOGICAL
     +   HLFRPT,PAGE,PRTFXD,WIDE
C
C  LOCAL ARRAYS
      INTEGER
     +   IFIXED(1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCKCNT,DCKER,DCKHDR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     EXTERNAL DCKHDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        ANALYTIC DERIVATIVES (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 .EQ. 1, ERRORS HAVE BEEN 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.  IF
C        IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED.  IF
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LIFIXD
C        THE LENGTH OF THE VECTOR IFIXED.
C     INTEGER LSCALE
C        THE LENGTH 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 N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
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     INTEGER NROW
C        THE USER-SUPPLIED NUMBER OF THE ROW OF THE INDEPENDENT
C        VARIABLE ARRAY AT WHICH THE DERIVATIVE IS TO BE CHECKED.
C     INTEGER NTAU
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES.
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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
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     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE ARRAY
C
C
C     CHECK FOR ERRORS IN INPUT PARAMETERS
C
      CALL DCKER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE)
C
      IF (IERR.NE.0) RETURN
C
      PAGE = .FALSE.
      WIDE = .TRUE.
      ISUBHD = 0
C
      PRTFXD = .FALSE.
      IFIXED(1) = -1
      LIFIXD = 1
C
      CALL STKSET(LDSTAK, 4)
C
C     PASS CONTROL OF DERIVATIVE CHECKING TO DCKCNT
C
      CALL DCKCNT (XM, N, M, IXM, MDL, DRV, PAR, NPAR, NETA,
     +   NTAU, SCALE, LSCALE, NROW, NPRT, DCKHDR, PAGE, WIDE, ISUBHD,
     +   HLFRPT, PRTFXD, IFIXED, LIFIXD)
C
      RETURN
C
      END
*DCKER
      SUBROUTINE DCKER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR DERIVATIVE CHECKING
C     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
     +   IXM,LDSTAK,LSCALE,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   SCALE(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,LDSMIN,NV
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERROR(10)
      CHARACTER
     +   LIXM(8)*1,LLDS(8)*1,LM(8)*1,LN(8)*1,LNPAR(8)*1,
     +   LSCL(8)*1,LZERO(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISLE,ERVGT,LDSCMP
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR(10)
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 VALUE.
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 WERE DETECTED.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
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 LIXM(8), LLDS(8), LM(8), LN(8), LNPAR(8), LSCL(8),
C    *   LZERO(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER LSCALE
C        THE LENGTH OF VECTOR SCALE.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND BY THE SCALE CHECKING ROUTINE.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C
C     SET UP NAME ARRAYS
C
      DATA LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6),
     +   LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/
      DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     +   LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',
     +   ' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5),
     +   LNPAR(6), LNPAR(7), LNPAR(8) /'N','P',' ',' ',' ',' ',' ',
     +   ' '/
      DATA LSCL(1), LSCL(2), LSCL(3), LSCL(4), LSCL(5),
     +   LSCL(6), LSCL(7), LSCL(8) /'S','C','A','L','E',' ',' ',
     +   ' '/
      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,10
         ERROR(I) = .FALSE.
   10 CONTINUE
C
      IERR = 0
      HEAD = .TRUE.
C
      CALL EISGE(NMSUB, LN, N, 1, 1, HEAD, ERROR(1), LN)
C
      CALL EISGE(NMSUB, LM, M, 1, 1, HEAD, ERROR(2), LM)
C
      CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(3), LN)
C
      CALL EISLE(NMSUB, LNPAR, NPAR, N, 2, HEAD, ERROR(4), LN)
C
      CALL LDSCMP(5, 0, 2*NPAR+1, 0, 0, 0, 'S',
     +            N*NPAR + NPAR + N, LDSMIN)
C
      IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(4)))
     +   CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(5),
     +   LLDS)
C
      CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 0, HEAD, 6, NV,
     +   ERROR(9), LZERO)
C
      DO 20 I=1,10
         IF (ERROR(I)) GO TO 30
   20 CONTINUE
      RETURN
C
   30 CONTINUE
      IERR = 1
      RETURN
C
      END
*DCKFPA
      SUBROUTINE DCKFPA(J, D, PAR, NPAR, ETA, TAU, MDL, XM, N,
     +   NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX, STP, PVPSTP,
     +   CURVE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CHECK WHETHER FINITE PRECISION ARITHMETIC COULD POSSIBLY BE THE
C     PROBLEM
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
      REAL
     +   CURVE,D,ETA,FD,PARMX,PV,PVPSTP,STP,TAU
      INTEGER
     +   IXM,J,LMSG,M,N,NPAR,NROW
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PVTEMP(N),XM(IXM,M)
      INTEGER
     +   MSG(LMSG)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  LOCAL SCALARS
      REAL
     +   TEMP
      LOGICAL
     +   LARGE
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SIGN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CURVE
C        A MEASURE OF THE CURVATURE IN THE MODEL.
C     REAL D
C        THE SCALAR IN WHICH ROW   NROW   OF THE DERIVATIVE
C        MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER
C        IS STORED.
C     REAL ETA
C        THE RELATIVE NOISE IN THE MODEL
C     REAL FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C     LOGICAL LARGE
C        AN INDICATOR VALUE INDICATING WHETHER THE RECOMMENDED
C        INCREASE IN THE STEP SIZE WOULD BE GREATER THAN PARMX.
C     INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
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 MSG(LMSG)
C        AN ARRAY USED TO STORE MESSAGE PARAMETERS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE
C        TYPICAL VALUE OF THAT PARAMETER
C     REAL PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
C     REAL PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP.
C     REAL PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUES FROM THE MODEL.
C     REAL STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
C     REAL TAU
C        THE AGREEMENT TOLERANCE.
C     REAL TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C     CHECK WHETHER FINITE PRECISION COULD BE THE PROBLEM
C
      IF (ABS(STP*(FD-D)) .GE.
     +   10.0E0*ETA*(ABS(PV)+ABS(PVPSTP))) THEN
C
C     DISCREPANCY BETWEEN NUMERICAL AND ANALYTICAL DERIVATIVES CANNOT
C     BE ACCOUNTED FOR BY FINITE PRECISION ARITHMETIC
C
         MSG(1) = 2
         MSG(J+1) = 2
         RETURN
C
      END IF
C
C     FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM.
C
C     TRY A LARGER STEP SIZE
C
      STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(1.0E0,PAR(J))/
     +   (TAU*ABS(D))+PAR(J)) - PAR(J)
C
      LARGE = .FALSE.
C
      IF (ABS(STP).GT.PARMX) THEN
         STP = PARMX*SIGN(1.0E0,PAR(J))
         LARGE = .TRUE.
      END IF
C
C     CALCULATE NUMERICAL DERIVATIVE USNG NEW, LARGER, STEPSIZE
C
      TEMP = PAR(J)
      PAR(J) = PAR(J) + STP
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP)
      PAR(J) = TEMP
C
      PVPSTP = PVTEMP(NROW)
C
      FD = (PVPSTP-PV)/STP
C
C     CHECK FOR AGREEMENT
C
      IF ((ABS(FD-D)).LE.2.0E0*TAU*ABS(D)) THEN
C
C     FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE FOR
C     THIS STEP SIZE
C
         RETURN
      END IF
C
C     FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES STILL
C     DISAGREE
C
C     CHECK IF CURVATURE IS THE PROBLEM
C
      IF (ABS(CURVE*STP) .LT. ABS(FD-D) .AND. (.NOT. LARGE)) THEN
C
C        CURVATURE COULDNT BE THE CULPRIT
C
             MSG(1) = 2
             MSG(J+1) = 2
             RETURN
      ELSE
C
C        CURVATURE MAY BE THE CULPRIT
C
             IF (MSG(1).EQ.0) MSG(1) = 1
             IF (LARGE) MSG(J+1) = 6
             IF (.NOT. LARGE) MSG(J+1) = 1
             RETURN
      END IF
C
      END
*DCKHDR
      SUBROUTINE DCKHDR(PAGE, WIDE, ISUBHD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE
C     DERIVATIVE CHECKING 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
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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        FULL WIDTH (TRUE) OR NOT (FALSE).
C
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT, 1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT, 1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT (21H+DERIVATIVE CHECKING,,
     +   10H CONTINUED)
 1010 FORMAT ('+', 23(1H*)/ 24H * DERIVATIVE CHECKING */ 1X, 23(1H*))
 1020 FORMAT ('1')
 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-'))
      END
*DCKLS1
      SUBROUTINE DCKLS1(N, M, IXM, PAR, NPAR, NETA, NTAU, NROW, SCALE,
     +   NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE
C     ROUTINES IN THE (LEAST SQUARES) STEP SIZE SELECTION FAMILY.
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,NETA,NPAR,NPRT,NROW,NTAU
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(10),SCALE(10)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NETA
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     INTEGER NTAU
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES.
C     REAL PAR(10)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL SCALE(10)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C
C
      PAR(1) = 1.0E0
      PAR(2) = 3.125E0
      PAR(3) = 1.0E0
      PAR(4) = 2.0E0
C
      N = 101
      M = 1
      IXM = 200
      NPAR = 4
      DO 10 I=1,10
         SCALE(I) = 1.0E0
   10 CONTINUE
      SCALE(2) = 0.01E0
      NETA = 0
      NTAU = 0
      NROW = 1
      NPRT = 1
C
      RETURN
C
      END
*DCKLSC
      SUBROUTINE DCKLSC(XM, N, M, IXM, MDL, DRV, PAR, NPAR, LDSTAK,
     +   NETA, NTAU, SCALE, NROW, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR CHECKING USER SUPPLIED
C     ANALYTIC DERIVATIVES AGAINST NUMERICAL DERIVATIVES
C     FOR THE NONLINEAR LEAST SQUARES ROUTINES (SHORT CALL).
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,LDSTAK,M,N,NETA,NPAR,NPRT,NROW,NTAU
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),SCALE(*),XM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LSCALE
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCKDRV,IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        ANALYTIC DERIVATIVES (JACOBIAN MATRIX) OF THE MODEL.
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 WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LSCALE
C        THE LENGTH 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 N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
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     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     INTEGER NTAU
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE
C        PARAMETERS ARE STORED.
C     REAL SCALE(NPAR)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'D','C','K','L','S','C'/
C
      LSCALE = NPAR
C
C     PASS CONTROL OF DERIVATIVE CHECKING TO DCKDRV
C
      CALL DCKDRV(NMSUB, LDSTAK, XM, N, M, IXM, MDL, DRV, PAR, NPAR,
     +   NETA, NTAU, SCALE, LSCALE, NROW, NPRT)
C
      IF (IERR.NE.1) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL DCKLSC (XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +             PAR, NPAR, LDSTAK,'/
     +   '      +             NETA, NTAU, SCALE, NROW, NPRT)')
      END
*DCKLS
      SUBROUTINE DCKLS(XM, N, M, IXM, MDL, DRV, PAR, NPAR, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR CHECKING USER SUPPLIED
C     ANALYTIC DERIVATIVES AGAINST NUMERICAL DERIVATIVES
C     FOR THE NONLINEAR LEAST SQUARES ROUTINES (SHORT CALL).
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,LDSTAK,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),XM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LSCALE,NETA,NPRT,NROW,NTAU
C
C  LOCAL ARRAYS
      REAL
     +   SCALE(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCKDRV,IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        ANALYTIC DERIVATIVES (JACOBIAN MATRIX) OF THE MODEL.
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 WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LSCALE
C        THE LENGTH 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 N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
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     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     INTEGER NTAU
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE
C        PARAMETERS ARE STORED.
C     REAL SCALE(1)
C        A DUMMY ARRAY, INDICATING USE OF DEFAULT VALUES FOR
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE MATRIX.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'D','C','K','L','S',' '/
C
C     SET DEFAULT VALUES
C
      NETA = 0
      NTAU = 0
      SCALE(1) = 0.0E0
      LSCALE = 1
      NPRT = 1
      NROW = 0
C
C     PASS CONTROL OF DERIVATIVE CHECKING TO DCKDRV
C
      CALL DCKDRV(NMSUB, LDSTAK, XM, N, M, IXM, MDL, DRV, PAR, NPAR,
     +   NETA, NTAU, SCALE, LSCALE, NROW, NPRT)
C
      IF (IERR.NE.1) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL DCKLS (XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +            PAR, NPAR, LDSTAK)')
      END
*DCKMN
      SUBROUTINE DCKMN(J, D, PAR, SCALE, NPAR, ETA, TAU, MDL, XM,
     +   N, NROW, M, IXM, PV, PVTEMP, MSG, LMSG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR CHECKING USER SUPPLIED
C     ANALYTIC DERIVATIVES 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
      REAL
     +   D,ETA,PV,SCALE,TAU
      INTEGER
     +   IXM,J,LMSG,M,N,NPAR,NROW
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PVTEMP(N),XM(IXM,M)
      INTEGER
     +   MSG(LMSG)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  LOCAL SCALARS
      REAL
     +   FD,PARMX,PVPSTP,STP,TEMP
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCKCRV,DCKZRO
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SIGN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL D
C        THE SCALAR IN WHICH ROW   NROW   OF THE DERIVATIVE
C        MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER
C        IS STORED.
C     REAL ETA
C        THE RELATIVE NOISE IN THE MODEL
C     REAL FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C     INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
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 MSG(LMSG)
C        AN ARRAY USED TO STORE MESSAGE PARAMETERS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE
C        TYPICAL VALUE OF THAT PARAMETER
C     REAL PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
C     REAL PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP.
C     REAL PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUE FROM THE MODEL.
C     REAL SCALE
C        THE TYPICAL SIZE OF THE JTH PARAMETER.
C     REAL STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
C     REAL TAU
C        THE AGREEMENT TOLERANCE.
C     REAL TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C     CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE
C     QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES
C
      MSG(J+1) = 0
C
      PARMX = MAX(ABS(PAR(J)),ABS(SCALE))
      IF (PARMX .EQ. 0.0E0) PARMX = 1.0E0
C
C     COMPUTE INITIAL STEP SIZE
C
      STP = (SQRT(ETA)*PARMX*SIGN(1.0E0,PAR(J))+PAR(J)) - PAR(J)
C
C     COMPUTE PREDICTED VALUES
C
      TEMP = PAR(J)
      PAR(J) = PAR(J) + STP
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP)
      PAR(J) = TEMP
C
      PVPSTP = PVTEMP(NROW)
C
      FD = (PVPSTP-PV)/STP
C
C     CHECK FOR DISAGREEMENT
C
      IF (ABS(FD-D) .GT. TAU*ABS(D)) GO TO 10
C
C     NUMERICAL AND ANALYTIC DERIVATIVES AGREE
C
C     CHECK IF ANALYTIC DERIVATIVE IS IDENTICALLY ZERO, INDICATING
C     THE POSSIBILITY THAT THE DERIVATIVE SHOULD BE RECHECKED AT
C     ANOTHER POINT.
C
      IF (D.NE.0.0E0) RETURN
C
C     JTH ANALYTIC AND NUMERICAL DERIVATIVES BOTH ARE ZERO.
C
      IF (MSG(1).EQ.0) MSG(1) = 1
      MSG(J+1) = 3
      RETURN
C
   10 CONTINUE
C
C     NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE
C
C     CHECK WHY
C
      IF (D.EQ.0.0E0) THEN
         CALL DCKZRO(J, PAR, NPAR, MDL, XM, N,
     +      NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX, PVPSTP,
     +      STP)
      ELSE
         CALL DCKCRV(J, D, PAR, NPAR, ETA, TAU, MDL, XM,
     +      N, NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX,
     +      PVPSTP, STP)
      END IF
C
      RETURN
      END
*DCKOUT
      SUBROUTINE DCKOUT(XM, IXM, N, M, NROW, NETA, NTAU, NPAR, MSG,
     +   LMSG, PAR, SCALE, LSCALE, HDR, PAGE, WIDE, ISUBHD, PRTFXD,
     +   IFIXD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE RESULTS OF THE DERIVATIVE CHECKING
C     SUBROUTINE
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
     +   ISUBHD,IXM,LMSG,LSCALE,M,N,NETA,NPAR,NROW,NTAU
      LOGICAL
     +   PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),SCALE(LSCALE),XM(IXM,M)
      INTEGER
     +   IFIXD(NPAR),MSG(LMSG)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL HDR
C
C  LOCAL SCALARS
      INTEGER
     +   I,IMAX,IMIN,INDEX,IPRT,J,K,NPERL
      CHARACTER
     +   BLANK*1
C
C  LOCAL ARRAYS
      LOGICAL
     +   FTNOTE(6)
      CHARACTER
     +   FIXED(3)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FIXPRT,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER*1 BLANK
C        THE CHARACTER BLANK.
C     CHARACTER*1 FIXED(3)
C        THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT.
C     LOGICAL FTNOTE(6)
C        THE ARRAY WHICH CONTROLS PRINTING OF FOOTNOTES.
C     EXTERNAL HDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING
C     INTEGER I
C        AN INDEX VARIABLE
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 IMAX, IMIN
C        THE LARGEST AND SMALLEST INDEX VALUE TO BE PRINTED ON EACH
C        LINE.
C     INTEGER INDEX
C        THE INDEX VALUE TO BE PRINTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED BY
C        ROUTINE HDR.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
C     INTEGER LSCALE
C        THE LENGTH OF VECTOR SCALE.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER MSG(LMSG)
C        AN ARRAY USED TO STORE MESSAGE PARAMETERS.
C     INTEGER NETA
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NPERL
C        THE NUMBER OF VALUES TO BE PRINTED PER LINE.
C     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     INTEGER NTAU
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        APPROXIMATED DERIVATIVES AND THE USER-SUPPLIED DERIVATIVES.
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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
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     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C     LOGICAL WIDE
C       THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        FULL WIDTH (TRUE) OR NOT (FALSE).
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
      DATA BLANK /' '/
C
      CALL IPRINT(IPRT)
C
C     INITIALIZE ARRAY FIXED
C
      DO 10 K=1,3
         FIXED(K) = BLANK
   10 CONTINUE
C
      CALL HDR(PAGE, WIDE, ISUBHD)
C
C     SET UP FOR FOOTNOTES
C
      DO 20 I=1,6
         FTNOTE(I) = .FALSE.
   20 CONTINUE
C
      IF (MSG(1).LE.0) GO TO 40
C
      DO 30 I=1,NPAR
         IF ((MSG(I+1).EQ.0) .OR. (MSG(I+1).EQ.2)) GO TO 30
         K = MSG(I+1) - 2
         IF (K.EQ.-1) K = 5
         FTNOTE(1) = .TRUE.
         FTNOTE(K+1) = .TRUE.
   30 CONTINUE
C
C     PRINT REPORT
C
   40 CONTINUE
C
      WRITE (IPRT,1000)
      IF (FTNOTE(1)) WRITE (IPRT,1040)
      IF (PRTFXD) WRITE (IPRT,1160)
      IF (.NOT.PRTFXD) WRITE (IPRT,1170)
C
      IF (SCALE(1).LE.0.0E0) GO TO 60
C
      DO 50 I=1,NPAR
         IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED)
         K = MSG(I+1) - 2
         IF (K.EQ.-1) K = 5
         IF (K.EQ.-2) WRITE (IPRT,1010) I, (FIXED(J),J=1,3), PAR(I),
     +      SCALE(I)
         IF (K.EQ.0) WRITE (IPRT,1020) I, (FIXED(J),J=1,3), PAR(I),
     +      SCALE(I)
         IF (K.GE.1) WRITE (IPRT,1030) I, (FIXED(J),J=1,3), PAR(I),
     +      SCALE(I), K
   50 CONTINUE
      GO TO 80
C
   60 CONTINUE
C
      DO 70 I=1,NPAR
         IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED)
         K = MSG(I+1) - 2
         IF (K.EQ.-1) K = 5
         IF (K.EQ.-2) WRITE (IPRT,1180) I, (FIXED(J),J=1,3), PAR(I)
         IF (K.EQ.0) WRITE (IPRT,1190) I, (FIXED(J),J=1,3), PAR(I)
         IF (K.GE.1) WRITE (IPRT,1200) I, (FIXED(J),J=1,3), PAR(I), K
   70 CONTINUE
C
   80 CONTINUE
C
C     PRINT FOOTNOTES
C
      IF (.NOT.FTNOTE(1)) GO TO 90
C
      WRITE (IPRT,1060)
      IF (FTNOTE(2)) WRITE (IPRT,1070)
      IF (FTNOTE(3)) WRITE (IPRT,1080)
      IF (FTNOTE(4)) WRITE (IPRT,1090)
      IF (FTNOTE(5)) WRITE (IPRT,1100)
      IF (FTNOTE(6)) WRITE (IPRT,1050)
C
   90 CONTINUE
C
      WRITE (IPRT,1110) NETA
      WRITE (IPRT,1120) NTAU
C
C     PRINT OUT ROW OF INDEPENDENT VARIABLE WHICH WAS CHECKED.
C
      WRITE (IPRT,1130) NROW
      NPERL = 7
C
      DO 100 I=1,M,NPERL
         IMIN = I
         IMAX = MIN(I+NPERL-1,M)
         WRITE (IPRT,1140) (INDEX,INDEX=IMIN,IMAX)
         WRITE (IPRT,1150) (XM(NROW,INDEX),INDEX=IMIN,IMAX)
  100 CONTINUE
      WRITE (IPRT,1210) N
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//)
 1010 FORMAT (1X, I3, 5X, 3A1, 2G17.8, 10X, 2HOK)
 1020 FORMAT (1X, I3, 5X, 3A1, 2G17.8, 7X, 9HINCORRECT)
 1030 FORMAT (1X, I3, 5X, 3A1, 2G17.8, 5X, 14HQUESTIONABLE (, I1, ')')
 1040 FORMAT (62X, 1H*)
 1050 FORMAT (/48H  (5) USER-SUPPLIED AND APPROXIMATED DERIVATIVES,
     +   14H DISAGREE, BUT/5X, 37H APPROXIMATED DERIVATIVE IS QUESTIONA,
     +   11HBLE BECAUSE, 6H RATIO/5X, 30H OF RELATIVE CURVATURE TO RELA,
     +   17HTIVE SLOPE IS TOO, 6H HIGH.)
 1060 FORMAT (/53H * NUMBERS IN PARENTHESES REFER TO THE FOLLOWING NOTE,
     +   2HS.)
 1070 FORMAT (/48H  (1) USER-SUPPLIED AND APPROXIMATED DERIVATIVES,
     +   11H AGREE, BUT/5X, 40H BOTH ARE ZERO.  RECHECK AT ANOTHER ROW.)
 1080 FORMAT (/48H  (2) USER-SUPPLIED AND APPROXIMATED DERIVATIVES,
     +   15H MAY AGREE, BUT/5X, 36H USER-SUPPLIED DERIVATIVE IS IDENTIC,
     +   9HALLY ZERO, 17H AND APPROXIMATED/5X, 21H DERIVATIVE IS ONLY A,
     +   18HPPROXIMATELY ZERO., 25H  RECHECK AT ANOTHER ROW.)
 1090 FORMAT (/48H  (3) USER-SUPPLIED AND APPROXIMATED DERIVATIVES,
     +   14H DISAGREE, BUT/5X, 37H USER-SUPPLIED DERIVATIVE IS IDENTICA,
     +   9HLLY ZERO., 12H  RECHECK AT/5X, 13H ANOTHER ROW.)
 1100 FORMAT (/48H  (4) USER-SUPPLIED AND APPROXIMATED DERIVATIVES,
     +   14H DISAGREE, BUT/5X, 37H APPROXIMATED DERIVATIVE IS QUESTIONA,
     +   11HBLE BECAUSE, 13H EITHER RATIO/5X, 22H OF RELATIVE CURVATURE,
     +   25H TO RELATIVE SLOPE IS TOO, 9H HIGH, OR/5X, 13H SCALE(K) IS ,
     +   6HWRONG.)
 1110 FORMAT (/43H NUMBER OF RELIABLE DIGITS IN MODEL RESULTS, 25X,
     +   6H(NETA), 1X, I5)
 1120 FORMAT (/40H NUMBER OF DIGITS IN DERIVATIVE CHECKING, 9H AGREEMEN,
     +   11HT TOLERANCE, 8X, 6H(NTAU), 1X, I5)
 1130 FORMAT (/45H ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED, 23X,
     +   6H(NROW), 1X, I5/42H   -VALUES OF THE INDEPENDENT VARIABLES AT,
     +   9H THIS ROW)
 1140 FORMAT (10X, 5HINDEX, I5, 6I15)
 1150 FORMAT (10X, 5HVALUE, 7(1X, G14.7)/)
 1160 FORMAT (52X, 10HDERIVATIVE/7X, 24HPARAMETER STARTING VALUE, 6X,
     +   5HSCALE, 10X, 10HASSESSMENT/1X, 5HINDEX, 2X, 5HFIXED, 6X,
     +   5H(PAR), 12X, 7H(SCALE)/)
 1170 FORMAT (17X, 9HPARAMETER, 26X, 10HDERIVATIVE/15X, 12HSTARTING VAL,
     +   2HUE, 8X, 5HSCALE, 10X, 10HASSESSMENT/1X, 5HINDEX, 13X,
     +   5H(PAR), 12X, 7H(SCALE)/)
 1180 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 13X, 2HOK)
 1190 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 10X, 9HINCORRECT)
 1200 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 8X, 11HQUESTIONABL,
     +   3HE (, I1, ')')
 1210 FORMAT (/23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5)
      END
*DCKZRO
      SUBROUTINE DCKZRO(J, PAR, NPAR, MDL, XM, N, NROW, M, IXM, PV,
     +   PVTEMP, MSG, LMSG, FD, PARMX, PVPSTP, STP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE RECHECKS THE DERIVATIES IN THE CASE WHERE THE FINITE
C     DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC DERIVATIVE AND T
C     ANALYTIC DERIVATIVE IS ZERO.
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
      REAL
     +   FD,PARMX,PV,PVPSTP,STP
      INTEGER
     +   IXM,J,LMSG,M,N,NPAR,NROW
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PVTEMP(N),XM(IXM,M)
      INTEGER
     +   MSG(LMSG)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  LOCAL SCALARS
      REAL
     +   CD,FPLRS,PVMSTP,TEMP,THIRD
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CD
C        THE CENTRAL DIFFERENCE QUOTIENT DERIVATIVE WITH
C        RESPECT TO THE JTH PARAMETER.
C     REAL FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER.
C     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C     INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
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 MSG(LMSG)
C        AN ARRAY USED TO STORE MESSAGE PARAMETERS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE TYPICAL
C        VALUE OF THAT PARAMETER.
C     REAL PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
C     REAL PVMSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) - STP.
C     REAL PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP.
C     REAL PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUES FROM THE MODEL.
C     REAL STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
C     REAL TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     REAL THIRD
C        THE VALUE 1/3.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
      FPLRS = R1MACH(4)
C
C     RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP
C     SIZE OF 2*STP
C
      TEMP = PAR(J)
      PAR(J) = PAR(J) - STP
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP)
      PAR(J) = TEMP
C
      PVMSTP = PVTEMP(NROW)
C
      CD = (PVPSTP-PVMSTP)/(2.0E0*STP)
C
C     CHECK FOR DISAGREEMENT
C
      IF (CD.NE.0.0E0) GO TO 10
C
C     NUMERICAL AND ANALYTIC DERIVATIVES NOW AGREE, BUT BOTH EQUAL ZERO,
C     INDICATING THAT DERIVATIVES SHOULD BE RECHECKED AT ANOTHER POINT.
C
      IF (MSG(1).EQ.0) MSG(1) = 1
      MSG(J+1) = 3
      RETURN
C
   10 CONTINUE
C
C     NUMERICAL AND ANALYTIC DERIVATIVE STILL DO NOT AGREE.
C
C     CHECK IF NUMERICAL DERIVATIVE IS CLOSE TO ZERO.
C
      THIRD = 1.0E0/3.0E0
      IF (MIN(ABS(CD), ABS(FD))*PARMX .GT. ABS(PV*FPLRS**THIRD))
     +   GO TO 20
C
C     NUMERICAL DERIVATIVE IS CLOSE TO ZERO
C
      IF (MSG(1).EQ.0) MSG(1) = 1
      MSG(J+1) = 4
      RETURN
C
   20 CONTINUE
C
C     NUMERICAL DERIVATIVE NOT CLOSE TO ZERO
C
      MSG(1) = 2
      MSG(J+1) = 5
      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
      REAL
     +   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     REAL PARDF(MBO)
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS.
C     REAL WORK(MBO,2)
C        A WORK ARRAY NECESSARY TO EXPAND THE DIFFERENCE FILTER.
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.0E0
   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
*DCSEVL
      DOUBLE PRECISION FUNCTION DCSEVL (X, A, N)
C
C     LATEST REVISION  -  OCTOBER 3, 1983  (JRD)
C
C EVALUATE THE N-TERM CHEBYSHEV SERIES A AT X.  ADAPTED FROM
C R. BROUCKE, ALGORITHM 446, C.A.C.M., 16, 254 (1973).
C
C             INPUT ARGUMENTS --
C X      DBLE PREC VALUE AT WHICH THE SERIES IS TO BE EVALUATED.
C A      DBLE PREC ARRAY OF N TERMS OF A CHEBYSHEV SERIES.  IN EVAL-
C        UATING A, ONLY HALF THE FIRST COEF IS SUMMED.
C N      NUMBER OF TERMS IN ARRAY A.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
      INTEGER N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION A(N)
C
C  LOCAL SCALARS
      DOUBLE PRECISION B0,B1,B2,TWOX
      INTEGER I,NI1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C
      IF (N.LT.1) CALL XERROR ('DCSEVL  NUMBER OF TERMS LE 0', 28, 2,2)
      IF (N.GT.1000) CALL XERROR ('DCSEVL  NUMBER OF TERMS GT 1000',
     1  31, 3, 2)
      IF (X.LT.(-1.D0) .OR. X.GT.1.D0) CALL XERROR (
     1  'DCSEVL  X OUTSIDE (-1,+1)', 25, 1, 1)
C
      TWOX = 2.0D0*X
      B0 = 0.0D0
      B1 = 0.0D0
      B2 = 0.0D0
      DO 10 I=1,N
        B2 = B1
        B1 = B0
        NI1 = N-I+1
        B0 = TWOX*B1 - B2 + A(NI1)
 10   CONTINUE
C
      DCSEVL = 0.5D0 * (B0-B2)
C
      RETURN
      END
*DEMDRV
      SUBROUTINE DEMDRV (Y, N, FD, FC, K, HLP, AMPL, PHASE, IPHASE,
     +   NDEM, NPRT, NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE DRIVER ROUTINE TO DEMODULATE SERIES
C     Y AT FREQUENCY FD, TO APPLY A LOW PASS FILTER WITH CUTOFF
C     FREQUENCY FC, AND TO EXTRACT THE AMPLITUDE AND PHASE COMPONENTS
C     OF THE RESULTING FILTERED SERIES .
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 147
C     ADAPTED FOR STARPAC BY  -  JANET R. DONALDSON
C                                STATISTICAL ENGINEERING DIVISION
C                                NATIONAL BUREAU OF STANDARDS
C                                BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FC,FD
      INTEGER
     +   IPHASE,K,N,NDEM,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   AMPL(N),HLP(K),PHASE(IPHASE,2),Y(N)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DEMODU,DEMORD,DEMOUT,FLTSL,LPFLT,POLAR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AMPL(N)
C        THE ARRAY IN WHICH THE AMPLITUDES ARE STORED.
C     REAL FC
C        THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER.
C     REAL FD
C        THE DEMODULATION FREQUENCY.
C     REAL HLP(K)
C        THE ARRAY IN WHICH THE LOW PASS FILTER COEFFICIENTS ARE
C        STORED.
C     INTEGER K
C        THE USER SUPPLIED NUMBER OF TERMS TO BE USED FOR THE LOW
C        PASS FILTER.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDEM
C        THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN
C        THE AMPLITUDE AND PHASE ARRAYS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF NPRT
C        IS ZERO, NO OUTPUT IS GIVEN, OTHERWISE OUTPUT IS PROVIDED.
C     REAL PHASE(IPHASE,2)
C        THE ARRAY CONTIANING THE PRIMARY AND SECONDARY PHASE ESTIMATES.
C     REAL Y(N)
C        THE INPUT ARRAY CONTAINING THE OBSERVED SERIES.
C
C
      CALL DEMODU (Y, N, FD, AMPL, PHASE)
      CALL LPFLT (FC, K, HLP)
      CALL FLTSL (AMPL, N, K, HLP, AMPL, NDEM)
      CALL FLTSL (PHASE, N, K, HLP, PHASE, NDEM)
C
      CALL POLAR (AMPL, PHASE, NDEM)
C
      IF (NPRT .EQ. 0) RETURN
C
      CALL DEMORD (PHASE, PHASE(1,2), NDEM, N)
      CALL DEMOUT (FD, FC, K, AMPL, PHASE, IPHASE, NDEM, NMSUB)
C
      RETURN
C
      END
*DEMOD
      SUBROUTINE DEMOD (Y, N, FD, FC, K, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE TO DEMODULATE SERIES
C     Y AT FREQUENCY FD, TO APPLY A LOW PASS FILTER WITH CUTOFF
C     FREQUENCY FC, AND TO EXTRACT THE AMPLITUDE AND PHASE COMPONENTS
C     OF THE RESULTING FILTERED SERIES (SHORT CALL).
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 147
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
      REAL
     +   FC,FD
      INTEGER
     +   K,LDSTAK,N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   TEMP
      INTEGER
     +   AMPL,HLP,IFP,IPRT,LDSMIN,NALL0,NDEM,PHASE
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,ERR06,ERR07,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      CHARACTER
     +   LFC(8)*1,LFD(8)*1,LK(8)*1,LKIN(8)*1,LLDS(8)*1,LN(8)*1,
     +   LNM1(8)*1,LONE(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DEMDRV,EISGE,EISII,ERIODD,ERSII,ERSLFS,IPRINT,LDSCMP,
     +   STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER AMPL
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE ARRAY IN WHICH THE AMPLITUDES ARE STORED.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05, ERR06, ERR07
C        VALUES INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FC
C        THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER.
C     REAL FD
C        THE DEMODULATION 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 HLP
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE ARRAY IN WHICH THE LOW PASS FILTER COEFFICIENTS ARE
C        STORED.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER K
C        THE USER SUPPLIED NUMBER OF TERMS TO BE USED FOR THE LOW
C        PASS FILTER.
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 LFC(8), LFD(8), LK(8), LKIN(8), LLDS(8), LN(8),
C    *  LNM1(8), LONE(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     INTEGER NDEM
C        THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN
C        THE AMPLITUDE AND PHASE ARRAYS.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER PHASE
C        THE STARTING LOCATIONS IN RSTAK/DSTAK OF
C        THE ARRAY CONTAINING THE PRIMARY AND SECONDARY PHASE ESTIMATES.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL TEMP
C        A TEMPORARY VARIABLE USED FOR TYPE CONVERSION.
C     REAL Y(N)
C        THE INPUT ARRAY CONTAINING THE OBSERVED SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'D',       'E',       'M',       'O',       'D',       ' '/
      DATA
     +  LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8)
     + /  'F',   'C',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LFD(1), LFD(2), LFD(3), LFD(4), LFD(5), LFD(6), LFD(7), LFD(8)
     + /  'F',   'D',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8)
     + /  'K',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LKIN(1), LKIN(2), LKIN(3), LKIN(4), LKIN(5), LKIN(6), LKIN(7),
     +  LKIN(8) /  '(',   '1',   '/',   'K',   ')',   ' ',   ' ',   ' '/
      DATA
     +  LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7),
     +  LLDS(8) /  'L',   'D',   'S',   'T',   'A',   'K',   ' ',   ' '/
      DATA
     +  LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8)
     + /  'N',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6), LNM1(7),
     +  LNM1(8) /  '(',   'N',   '-',   '1',   ')',   ' ',   ' ',   ' '/
      DATA
     +  LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7),
     +  LONE(8) /  'O',   'N',   'E',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     PERFORM ERROR CHECKING ON INPUT DATA.
C
      IERR = 0
      HEAD = .TRUE.
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN)
C
      CALL ERSII(NMSUB, LFD, FD,
     +           0.0E0, 0.5E0, 2, HEAD, ERR02, LFD, LFD)
C
      ERR03 = .TRUE.
      IF (.NOT. ERR01)
     +  CALL EISII(NMSUB, LK, K, 1, N-1, 1, HEAD, ERR03, LONE, LNM1)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04)
C
      ERR05 = .TRUE.
      IF ((.NOT. ERR02) .AND. (.NOT. ERR03) .AND. (.NOT. ERR04)) THEN
         TEMP = K
         CALL ERSII(NMSUB, LFC, FC, 1.0E0/TEMP, FD, 1, HEAD, ERR05,
     +              LKIN, LFD)
      END IF
C
      ERR06 = .TRUE.
      IF ((.NOT. ERR03) .AND. (.NOT. ERR04) .AND. (.NOT. ERR05))
     +   CALL ERSLFS(NMSUB, FC, K, HEAD, ERR06)
C
      IF (ERR01 .OR. ERR06) GO TO 10
C
      CALL LDSCMP(3, 0, 0, 0, 0, 0, 'S', K + 3*N, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR07, LLDS)
C
C
      IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05 .OR. ERR07) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
      CALL STKSET (LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
      AMPL = STKGET(N, IFP)
      PHASE = STKGET(2*N, IFP)
      HLP = STKGET(K, IFP)
C
      IF (IERR .EQ. 1) GO TO 10
C
      CALL DEMDRV(Y, N, FD, FC, K, RSTAK(HLP), RSTAK(AMPL),
     +   RSTAK(PHASE), N, NDEM, 1, NMSUB)
C
      CALL STKCLR(NALL0)
C
      IF (IERR .EQ. 1) GO TO 10
C
      RETURN
C
C     FORMAT STATEMENT
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL DEMOD (Y, N, FD, FC, K, LDSTAK)')
C
      END
*DEMODS
      SUBROUTINE DEMODS (Y, N, FD, FC, K, AMPL, PHAS, NDEM, NPRT,
     +  LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE TO DEMODULATE SERIES
C     Y AT FREQUENCY FD, TO APPLY A LOW PASS FILTER WITH CUTOFF
C     FREQUENCY FC, AND TO EXTRACT THE AMPLITUDE AND PHASE COMPONENTS
C     OF THE RESULTING FILTERED SERIES (LONG CALL).
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 147
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
      REAL
     +   FC,FD
      INTEGER
     +   K,LDSTAK,N,NDEM,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   AMPL(*),PHAS(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   TEMP
      INTEGER
     +   HLP,IO,IPRT,LDSMIN,NALL0,PHASE
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,ERR06,ERR07,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      CHARACTER
     +   LFC(8)*1,LFD(8)*1,LK(8)*1,LKIN(8)*1,LLDS(8)*1,LN(8)*1,
     +   LNM1(8)*1,LONE(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DEMDRV,EISGE,EISII,ERIODD,ERSII,ERSLFS,IPRINT,LDSCMP,
     +   SCOPY,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AMPL(N)
C        THE ARRAY IN WHICH THE AMPLITUDES ARE STORED.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05, ERR06, ERR07
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FC
C        THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER.
C     REAL FD
C        THE DEMODULATION 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 HLP
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE ARRAY IN WHICH THE LOW PASS FILTER COEFFICIENTS ARE
C        STORED.
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 IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER K
C        THE USER SUPPLIED NUMBER OF TERMS TO BE USED FOR THE LOW
C        PASS FILTER.
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 LFC(8), LFD(8), LK(8), LKIN(8), LLDS(8), LN(8),
C    *  LNM1(8), LONE(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     INTEGER NDEM
C        THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN
C        THE AMPLITUDE AND PHASE ARRAYS.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF NPRT
C        IS ZERO, NO OUTPUT IS GIVEN, OTHERWISE OUTPUT IS PROVIDED.
C     REAL PHAS(N)
C        THE ARRAY IN WHICH THE PRIMARY PHASE ESTIMATES ARE RETURNED.
C     INTEGER PHASE
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE ARRAY CONTAINING THE PRIMARY AND SECONDARY PHASE ESTIMATES.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL TEMP
C        A TEMPORARY VARIABLE USED FOR TYPE CONVERSION.
C     REAL Y(N)
C        THE INPUT ARRAY CONTAINING THE OBSERVED SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'D',       'E',       'M',       'O',       'D',       'S'/
      DATA
     +  LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8)
     + /  'F',   'C',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LFD(1), LFD(2), LFD(3), LFD(4), LFD(5), LFD(6), LFD(7), LFD(8)
     + /  'F',   'D',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8)
     + /  'K',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LKIN(1), LKIN(2), LKIN(3), LKIN(4), LKIN(5), LKIN(6), LKIN(7),
     +  LKIN(8) /  '(',   '1',   '/',   'K',   ')',   ' ',   ' ',   ' '/
      DATA
     +  LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7),
     +  LLDS(8) /  'L',   'D',   'S',   'T',   'A',   'K',   ' ',   ' '/
      DATA
     +  LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8)
     + /  'N',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6), LNM1(7),
     +  LNM1(8) /  '(',   'N',   '-',   '1',   ')',   ' ',   ' ',   ' '/
      DATA
     +  LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7),
     +  LONE(8) /  'O',   'N',   'E',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     PERFORM ERROR CHECKING ON INPUT DATA.
C
      IERR = 0
      HEAD = .TRUE.
C
      IF (NPRT.EQ.0) THEN
        IO = 0
      ELSE
        IO = 1
      END IF
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN)
C
      CALL ERSII(NMSUB, LFD, FD,
     +           0.0E0, 0.5E0, 2, HEAD, ERR02, LFD, LFD)
C
      ERR03 = .TRUE.
      IF (.NOT. ERR01)
     +  CALL EISII(NMSUB, LK, K, 1, N-1, 1, HEAD, ERR03, LONE, LNM1)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04)
C
      ERR05 = .TRUE.
      IF ((.NOT. ERR02) .AND. (.NOT. ERR03) .AND. (.NOT. ERR04)) THEN
         TEMP = K
         CALL ERSII(NMSUB, LFC, FC, 1.0E0/TEMP, FD, 1, HEAD, ERR05,
     +              LKIN, LFD)
      END IF
C
      ERR06 = .TRUE.
      IF ((.NOT. ERR03) .AND. (.NOT. ERR04) .AND. (.NOT. ERR05))
     +   CALL ERSLFS(NMSUB, FC, K, HEAD, ERR06)
C
      IF (ERR01 .OR. ERR06) GO TO 10
C
      CALL LDSCMP(2, 0, 0, 0, 0, 0, 'S', K + IO*2*N, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR07, LLDS)
C
C
      IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05 .OR. ERR07) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
      CALL STKSET (LDSTAK, 4)
      NALL0 = STKST(1)
C
      HLP = STKGET(K, 3)
      IF (NPRT.EQ.0) THEN
         PHASE = 1
      ELSE
         PHASE = STKGET(2*N, 3)
      END IF
C
      IF (IERR .EQ. 1) GO TO 10
C
      IF (NPRT .NE. 0) THEN
C
         CALL DEMDRV(Y, N, FD, FC, K, RSTAK(HLP), AMPL,
     +      RSTAK(PHASE), N, NDEM, NPRT, NMSUB)
         CALL SCOPY(NDEM, RSTAK(PHASE), 1, PHAS, 1)
      ELSE
         CALL DEMDRV(Y, N, FD, FC, K, RSTAK(HLP), AMPL,
     +      PHAS, N, NDEM, NPRT, NMSUB)
      END IF
C
      CALL STKCLR(NALL0)
C
      IF (IERR .EQ. 1) GO TO 10
C
      RETURN
C
C     FORMAT STATEMENT
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL DEMODS (Y, N, FD, FC, K,'/
     +   '      +             AMPL, PHAS, NDEM, NPRT, LDSTAK)')
C
      END
*DEMODU
      SUBROUTINE DEMODU (Y, N, FD, AMPL, PHAS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE DEMODULATES THE SERIES Y AT FREQUENCY
C     FD.  THE REAL AND IMAGINARY PARTS OF THE DEMODULATED
C     SERIES ARE RETURNED IN AMPL AND PHAS, RESPECTIVELY.
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 148
C     ADAPTED FOR STARPAC BY  -  JANET R. DONALDSON
C                                STATISTICAL ENGINEERING DEVISION
C                                NATIONAL BUREAU OF STANDARDS
C                                BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FD
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   AMPL(N),PHAS(N),Y(N)
C
C  LOCAL SCALARS
      REAL
     +   ARG,PI
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS,SIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AMPL(N)
C        THE ARRAY IN WHICH THE AMPLITUDES ARE STORED.
C     REAL ARG
C        A VALUE USED IN COMPUTING THE DEMODULATED SERIES.
C     REAL FD
C        THE DEMODULATION FREQUENCY.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES BEING DEMODULATED.
C     REAL PHAS(N)
C        THE ARRAYS CONTAINING THE PRIMARY PHASE ESTIMATES.
C     REAL PI
C        THE VALUE OF PI.
C     REAL Y(N)
C        THE INPUT ARRAY ARRAY CONTAINING THE OBSERVED SERIES.
C
      CALL GETPI(PI)
C
      DO 10 I = 1, N
         IF (FD.EQ.0.25E0) THEN
            AMPL(I) = 0.0E0
            PHAS(I) = -2.0E0*Y(I)
         ELSE IF (FD.EQ.0.5E0) THEN
            AMPL(I) = -2.0E0*Y(I)
            PHAS(I) = 0.0E0
         ELSE
            ARG = (I-1) * FD * 2.0E0 * PI
            AMPL(I) = Y(I)*COS(ARG)*2.0E0
            PHAS(I) = -Y(I)*SIN(ARG)*2.0E0
         END IF
   10 CONTINUE
      RETURN
      END
*DEMORD
      SUBROUTINE DEMORD (PHAS1, PHAS2, NDEM, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE SETS UP THE DATA FOR THE PHASE PLOTS.
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
     +   N,NDEM
C
C  ARRAY ARGUMENTS
      REAL
     +   PHAS1(N),PHAS2(N)
C
C  LOCAL SCALARS
      REAL
     +   PI
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES BEING DEMODULATED.
C     INTEGER NDEM
C        THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN
C        THE AMPLITUDE AND PHASE ARRAYS.
C     REAL PHAS1(N), PHAS2(N)
C        THE ARRAYS CONTAINING THE PRIMARY AND SECONDARY PHASE
C        ESTIMATES, RESPECTIVELY.
C     REAL PI
C        THE VALUE OF PI.
C
      CALL GETPI(PI)
C
      DO 10 I = 1, NDEM
         PHAS2(I) = 0.0E0
         IF (PHAS1(I) .GT. 0.0E0) PHAS2(I) = PHAS1(I) - 2.0E0*PI
         IF (PHAS1(I) .LT. 0.0E0) PHAS2(I) = PHAS1(I) + 2.0E0*PI
   10 CONTINUE
C
      RETURN
      END
*DEMOUT
      SUBROUTINE DEMOUT(FD, FC, K, AMPL, PHASE, IPHASE, NDEM, NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRODUCES THE OUTPUT FOR THE TIME SERIES
C     DEMODULATION ROUTINE.
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
      REAL
     +   FC,FD
      INTEGER
     +   IPHASE,K,NDEM
C
C  ARRAY ARGUMENTS
      REAL
     +   AMPL(NDEM),PHASE(IPHASE,2)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   PI,YMN,YMX
      INTEGER
     +   IPRT
      LOGICAL
     +   ERROR
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI,IPRINT,VERSP,VPLMT,VPMN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AMPL(NDEM)
C        THE ARRAY IN WHICH THE AMPLITUDES OF THE DEMODULATED SERIES
C        ARE STORED.
C     LOGICAL ERROR
C        AN ERROR FLAG
C     REAL FC, FD
C        THE CUTOFF FREQUENCY AND THE DEMODULATION FREQUENCY.
C     INTEGER IERR
C        THE ERROR FLAG
C     INTEGER IPHASE
C
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISYM(1)
C        A DUMMY ARRAY.
C     INTEGER K
C        THE NUMBER OF TERMS IN THE LOW PASS FILTER USED TO SMOOTH
C        THE DEMODULATED SERIES.
C     INTEGER NDEM
C        THE NUMBER OF VALUES IN THE DEMODULATED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE
C     REAL PHASE(IPHASE,2)
C        THE ARRAY CONTAINING THE PRIMARY AND SECONDARY PHASE VALUES.
C     REAL PI
C        THE VALUE OF PI.
C     REAL YMN, YMX
C
C
      CALL IPRINT(IPRT)
C
      CALL VERSP(.TRUE.)
C
      CALL GETPI(PI)
C
      WRITE (IPRT, 1000) FD, FC, K
C
      WRITE (IPRT, 1001)
      CALL VPLMT(AMPL, AMPL, NDEM, 1, NDEM, 0.0E0, 0.0E0,
     +  YMN, YMX, ERROR, NMSUB, .FALSE., 1)
C
      IF (ERROR) THEN
        IERR = 1
        RETURN
      ELSE
        CALL VPMN(AMPL, AMPL, NDEM, 1, NDEM, 1, 0, ISYM, 1, 0,
     +   YMN, YMX, 1.0E0, 1.0E0, .FALSE., 0, 1, 0)
      END IF
C
      WRITE (IPRT, 1002)
      CALL VERSP(.TRUE.)
      WRITE (IPRT, 1003)
      CALL VPMN(PHASE, PHASE, NDEM, 2, IPHASE, 1, 2, ISYM, 1, 0,
     +   -2.0E0*PI, 2.0E0*PI, 1.0E0, 1.0E0, .FALSE., 0, 0, 0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/25H TIME SERIES DEMODULATION//
     +   26H DEMODULATION FREQUENCY IS, F10.8/
     +   26H CUTOFF FREQUENCY IS      , F10.8/
     +   38H THE NUMBER OF TERMS IN THE FILTER IS , I5///)
 1001 FORMAT (49H PLOT OF AMPLITUDE OF SMOOTHED DEMODULATED SERIES)
 1002 FORMAT ('1')
 1003 FORMAT (45H PLOT OF PHASE OF SMOOTHED DEMODULATED SERIES)
      END
*DERFC
      DOUBLE PRECISION FUNCTION DERFC (X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
C
C  LOCAL SCALARS
      DOUBLE PRECISION SQEPS,SQRTPI,XMAX,XSML,Y
      REAL ETA
      INTEGER NTERC2,NTERF,NTERFC
C
C  LOCAL ARRAYS
      DOUBLE PRECISION ERC2CS(49),ERFCCS(59),ERFCS(21)
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,DCSEVL
      INTEGER INITDS
      EXTERNAL D1MACH,DCSEVL,INITDS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DSQRT,EXP,LOG,SNGL
C
C
C SERIES FOR ERF        ON THE INTERVAL  0.          TO  1.00000E+00
C                                        WITH WEIGHTED ERROR   1.28E-32
C                                         LOG WEIGHTED ERROR  31.89
C                               SIGNIFICANT FIGURES REQUIRED  31.05
C                                    DECIMAL PLACES REQUIRED  32.55
C
      DATA ERF CS(  1) / -.4904612123 4691808039 9845440333 76 D-1     /
      DATA ERF CS(  2) / -.1422612051 0371364237 8247418996 31 D+0     /
      DATA ERF CS(  3) / +.1003558218 7599795575 7546767129 33 D-1     /
      DATA ERF CS(  4) / -.5768764699 7674847650 8270255091 67 D-3     /
      DATA ERF CS(  5) / +.2741993125 2196061034 4221607914 71 D-4     /
      DATA ERF CS(  6) / -.1104317550 7344507604 1353812959 05 D-5     /
      DATA ERF CS(  7) / +.3848875542 0345036949 9613114981 74 D-7     /
      DATA ERF CS(  8) / -.1180858253 3875466969 6317518015 81 D-8     /
      DATA ERF CS(  9) / +.3233421582 6050909646 4029309533 54 D-10    /
      DATA ERF CS( 10) / -.7991015947 0045487581 6073747085 95 D-12    /
      DATA ERF CS( 11) / +.1799072511 3961455611 9672454866 34 D-13    /
      DATA ERF CS( 12) / -.3718635487 8186926382 3168282094 93 D-15    /
      DATA ERF CS( 13) / +.7103599003 7142529711 6899083946 66 D-17    /
      DATA ERF CS( 14) / -.1261245511 9155225832 4954248533 33 D-18    /
      DATA ERF CS( 15) / +.2091640694 1769294369 1705002666 66 D-20    /
      DATA ERF CS( 16) / -.3253973102 9314072982 3641600000 00 D-22    /
      DATA ERF CS( 17) / +.4766867209 7976748332 3733333333 33 D-24    /
      DATA ERF CS( 18) / -.6598012078 2851343155 1999999999 99 D-26    /
      DATA ERF CS( 19) / +.8655011469 9637626197 3333333333 33 D-28    /
      DATA ERF CS( 20) / -.1078892517 7498064213 3333333333 33 D-29    /
      DATA ERF CS( 21) / +.1281188399 3017002666 6666666666 66 D-31    /
C
C SERIES FOR ERC2       ON THE INTERVAL  2.50000E-01 TO  1.00000E+00
C                                        WITH WEIGHTED ERROR   2.67E-32
C                                         LOG WEIGHTED ERROR  31.57
C                               SIGNIFICANT FIGURES REQUIRED  30.31
C                                    DECIMAL PLACES REQUIRED  32.42
C
      DATA ERC2CS(  1) / -.6960134660 2309501127 3915082619 7 D-1      /
      DATA ERC2CS(  2) / -.4110133936 2620893489 8221208466 6 D-1      /
      DATA ERC2CS(  3) / +.3914495866 6896268815 6114370524 4 D-2      /
      DATA ERC2CS(  4) / -.4906395650 5489791612 8093545077 4 D-3      /
      DATA ERC2CS(  5) / +.7157479001 3770363807 6089414182 5 D-4      /
      DATA ERC2CS(  6) / -.1153071634 1312328338 0823284791 2 D-4      /
      DATA ERC2CS(  7) / +.1994670590 2019976350 5231486770 9 D-5      /
      DATA ERC2CS(  8) / -.3642666471 5992228739 3611843071 1 D-6      /
      DATA ERC2CS(  9) / +.6944372610 0050125899 3127721463 3 D-7      /
      DATA ERC2CS( 10) / -.1371220902 1043660195 3460514121 0 D-7      /
      DATA ERC2CS( 11) / +.2788389661 0071371319 6386034808 7 D-8      /
      DATA ERC2CS( 12) / -.5814164724 3311615518 6479105031 6 D-9      /
      DATA ERC2CS( 13) / +.1238920491 7527531811 8016881795 0 D-9      /
      DATA ERC2CS( 14) / -.2690639145 3067434323 9042493788 9 D-10     /
      DATA ERC2CS( 15) / +.5942614350 8479109824 4470968384 0 D-11     /
      DATA ERC2CS( 16) / -.1332386735 7581195792 8775442057 0 D-11     /
      DATA ERC2CS( 17) / +.3028046806 1771320171 7369724330 4 D-12     /
      DATA ERC2CS( 18) / -.6966648814 9410325887 9586758895 4 D-13     /
      DATA ERC2CS( 19) / +.1620854541 0539229698 1289322762 8 D-13     /
      DATA ERC2CS( 20) / -.3809934465 2504919998 7691305772 9 D-14     /
      DATA ERC2CS( 21) / +.9040487815 9788311493 6897101297 5 D-15     /
      DATA ERC2CS( 22) / -.2164006195 0896073478 0981204700 3 D-15     /
      DATA ERC2CS( 23) / +.5222102233 9958549846 0798024417 2 D-16     /
      DATA ERC2CS( 24) / -.1269729602 3645553363 7241552778 0 D-16     /
      DATA ERC2CS( 25) / +.3109145504 2761975838 3622741295 1 D-17     /
      DATA ERC2CS( 26) / -.7663762920 3203855240 0956671481 1 D-18     /
      DATA ERC2CS( 27) / +.1900819251 3627452025 3692973329 0 D-18     /
      DATA ERC2CS( 28) / -.4742207279 0690395452 2565599996 5 D-19     /
      DATA ERC2CS( 29) / +.1189649200 0765283828 8068307845 1 D-19     /
      DATA ERC2CS( 30) / -.3000035590 3257802568 4527131306 6 D-20     /
      DATA ERC2CS( 31) / +.7602993453 0432461730 1938527709 8 D-21     /
      DATA ERC2CS( 32) / -.1935909447 6068728815 6981104913 0 D-21     /
      DATA ERC2CS( 33) / +.4951399124 7733378810 0004238677 3 D-22     /
      DATA ERC2CS( 34) / -.1271807481 3363718796 0862198988 8 D-22     /
      DATA ERC2CS( 35) / +.3280049600 4695130433 1584165205 3 D-23     /
      DATA ERC2CS( 36) / -.8492320176 8228965689 2479242239 9 D-24     /
      DATA ERC2CS( 37) / +.2206917892 8075602235 1987998719 9 D-24     /
      DATA ERC2CS( 38) / -.5755617245 6965284983 1281950719 9 D-25     /
      DATA ERC2CS( 39) / +.1506191533 6392342503 5414405119 9 D-25     /
      DATA ERC2CS( 40) / -.3954502959 0187969531 0428569599 9 D-26     /
      DATA ERC2CS( 41) / +.1041529704 1515009799 8464505173 3 D-26     /
      DATA ERC2CS( 42) / -.2751487795 2787650794 5017890133 3 D-27     /
      DATA ERC2CS( 43) / +.7290058205 4975574089 9770368000 0 D-28     /
      DATA ERC2CS( 44) / -.1936939645 9159478040 7750109866 6 D-28     /
      DATA ERC2CS( 45) / +.5160357112 0514872983 7005482666 6 D-29     /
      DATA ERC2CS( 46) / -.1378419322 1930940993 8964480000 0 D-29     /
      DATA ERC2CS( 47) / +.3691326793 1070690422 5109333333 3 D-30     /
      DATA ERC2CS( 48) / -.9909389590 6243654206 5322666666 6 D-31     /
      DATA ERC2CS( 49) / +.2666491705 1953884133 2394666666 6 D-31     /
C
C SERIES FOR ERFC       ON THE INTERVAL  0.          TO  2.50000E-01
C                                        WITH WEIGHTED ERROR   1.53E-31
C                                         LOG WEIGHTED ERROR  30.82
C                               SIGNIFICANT FIGURES REQUIRED  29.47
C                                    DECIMAL PLACES REQUIRED  31.70
C
      DATA ERFCCS(  1) / +.7151793102 0292477450 3697709496 D-1        /
      DATA ERFCCS(  2) / -.2653243433 7606715755 8893386681 D-1        /
      DATA ERFCCS(  3) / +.1711153977 9208558833 2699194606 D-2        /
      DATA ERFCCS(  4) / -.1637516634 5851788416 3746404749 D-3        /
      DATA ERFCCS(  5) / +.1987129350 0552036499 5974806758 D-4        /
      DATA ERFCCS(  6) / -.2843712412 7665550875 0175183152 D-5        /
      DATA ERFCCS(  7) / +.4606161308 9631303696 9379968464 D-6        /
      DATA ERFCCS(  8) / -.8227753025 8792084205 7766536366 D-7        /
      DATA ERFCCS(  9) / +.1592141872 7709011298 9358340826 D-7        /
      DATA ERFCCS( 10) / -.3295071362 2528432148 6631665072 D-8        /
      DATA ERFCCS( 11) / +.7223439760 4005554658 1261153890 D-9        /
      DATA ERFCCS( 12) / -.1664855813 3987295934 4695966886 D-9        /
      DATA ERFCCS( 13) / +.4010392588 2376648207 7671768814 D-10       /
      DATA ERFCCS( 14) / -.1004816214 4257311327 2170176283 D-10       /
      DATA ERFCCS( 15) / +.2608275913 3003338085 9341009439 D-11       /
      DATA ERFCCS( 16) / -.6991110560 4040248655 7697812476 D-12       /
      DATA ERFCCS( 17) / +.1929492333 2617070862 4205749803 D-12       /
      DATA ERFCCS( 18) / -.5470131188 7543310649 0125085271 D-13       /
      DATA ERFCCS( 19) / +.1589663309 7626974483 9084032762 D-13       /
      DATA ERFCCS( 20) / -.4726893980 1975548392 0369584290 D-14       /
      DATA ERFCCS( 21) / +.1435873376 7849847867 2873997840 D-14       /
      DATA ERFCCS( 22) / -.4449510561 8173583941 7250062829 D-15       /
      DATA ERFCCS( 23) / +.1404810884 7682334373 7305537466 D-15       /
      DATA ERFCCS( 24) / -.4513818387 7642108962 5963281623 D-16       /
      DATA ERFCCS( 25) / +.1474521541 0451330778 7018713262 D-16       /
      DATA ERFCCS( 26) / -.4892621406 9457761543 6841552532 D-17       /
      DATA ERFCCS( 27) / +.1647612141 4106467389 5301522827 D-17       /
      DATA ERFCCS( 28) / -.5626817176 3294080929 9928521323 D-18       /
      DATA ERFCCS( 29) / +.1947443382 2320785142 9197867821 D-18       /
      DATA ERFCCS( 30) / -.6826305642 9484207295 6664144723 D-19       /
      DATA ERFCCS( 31) / +.2421988887 2986492401 8301125438 D-19       /
      DATA ERFCCS( 32) / -.8693414133 5030704256 3800861857 D-20       /
      DATA ERFCCS( 33) / +.3155180346 2280855712 2363401262 D-20       /
      DATA ERFCCS( 34) / -.1157372324 0496087426 1239486742 D-20       /
      DATA ERFCCS( 35) / +.4288947161 6056539462 3737097442 D-21       /
      DATA ERFCCS( 36) / -.1605030742 0576168500 5737770964 D-21       /
      DATA ERFCCS( 37) / +.6063298757 4538026449 5069923027 D-22       /
      DATA ERFCCS( 38) / -.2311404251 6979584909 8840801367 D-22       /
      DATA ERFCCS( 39) / +.8888778540 6618855255 4702955697 D-23       /
      DATA ERFCCS( 40) / -.3447260576 6513765223 0718495566 D-23       /
      DATA ERFCCS( 41) / +.1347865460 2069650682 7582774181 D-23       /
      DATA ERFCCS( 42) / -.5311794071 1250217364 5873201807 D-24       /
      DATA ERFCCS( 43) / +.2109341058 6197831682 8954734537 D-24       /
      DATA ERFCCS( 44) / -.8438365587 9237891159 8133256738 D-25       /
      DATA ERFCCS( 45) / +.3399982524 9452089062 7359576337 D-25       /
      DATA ERFCCS( 46) / -.1379452388 0732420900 2238377110 D-25       /
      DATA ERFCCS( 47) / +.5634490311 8332526151 3392634811 D-26       /
      DATA ERFCCS( 48) / -.2316490434 4770654482 3427752700 D-26       /
      DATA ERFCCS( 49) / +.9584462844 6018101526 3158381226 D-27       /
      DATA ERFCCS( 50) / -.3990722880 3301097262 4224850193 D-27       /
      DATA ERFCCS( 51) / +.1672129225 9444773601 7228709669 D-27       /
      DATA ERFCCS( 52) / -.7045991522 7660138563 8803782587 D-28       /
      DATA ERFCCS( 53) / +.2979768402 8642063541 2357989444 D-28       /
      DATA ERFCCS( 54) / -.1262522466 4606192972 2422632994 D-28       /
      DATA ERFCCS( 55) / +.5395438704 5424879398 5299653154 D-29       /
      DATA ERFCCS( 56) / -.2380992882 5314591867 5346190062 D-29       /
      DATA ERFCCS( 57) / +.1099052830 1027615735 9726683750 D-29       /
      DATA ERFCCS( 58) / -.4867713741 6449657273 2518677435 D-30       /
      DATA ERFCCS( 59) / +.1525877264 1103575676 3200828211 D-30       /
C
      DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 /
      DATA NTERF, NTERFC, NTERC2, XSML, XMAX, SQEPS / 3*0, 3*0.D0 /
C
      IF (NTERF.NE.0) GO TO 10
      ETA = 0.1*SNGL(D1MACH(3))
      NTERF = INITDS (ERFCS, 21, ETA)
      NTERFC = INITDS (ERFCCS, 59, ETA)
      NTERC2 = INITDS (ERC2CS, 49, ETA)
C
      XSML = -DSQRT (-LOG(SQRTPI*D1MACH(3)))
      XMAX = DSQRT (-LOG(SQRTPI*D1MACH(1)) )
      XMAX = XMAX - 0.5D0*LOG(XMAX)/XMAX - 0.01D0
      SQEPS = DSQRT (2.0D0*D1MACH(3))
C
 10   IF (X.GT.XSML) GO TO 20
C
C ERFC(X) = 1.0 - ERF(X)  FOR  X .LT. XSML
C
      DERFC = 2.0D0
      RETURN
C
 20   IF (X.GT.XMAX) GO TO 40
      Y = ABS(X)
      IF (Y.GT.1.0D0) GO TO 30
C
C ERFC(X) = 1.0 - ERF(X)  FOR ABS(X) .LE. 1.0
C
      IF (Y.LT.SQEPS) THEN
         DERFC = 1.0D0 - 2.0D0*X/SQRTPI
      ELSE
         DERFC = 1.0D0 - X*(1.0D0+DCSEVL(2.0D0*X*X-1.0D0,ERFCS,NTERF))
      END IF
C
      RETURN
C
C ERFC(X) = 1.0 - ERF(X)  FOR  1.0 .LT. ABS(X) .LE. XMAX
C
 30   Y = Y*Y
      IF (Y.LE.4.0D0) THEN
         DERFC = EXP(-Y)/ABS(X) *
     +           (0.5D0 + DCSEVL((8.0D0/Y-5.0D0)/3.0D0,ERC2CS,NTERC2))
      ELSE
         DERFC = EXP(-Y)/ABS(X) *
     +           (0.5D0 + DCSEVL(8.0D0/Y-1.0D0,ERFCCS,NTERFC))
      END IF
      IF (X.LT.0.D0) DERFC = 2.0D0 - DERFC
      RETURN
C
 40   CALL XERROR ('DERFC   X SO BIG ERFC UNDERFLOWS', 32, 1, 1)
      DERFC = 0.D0
      RETURN
C
      END
*DERF
      DOUBLE PRECISION FUNCTION DERF (X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
C
C  LOCAL SCALARS
      DOUBLE PRECISION SQEPS,SQRTPI,XBIG,Y
      INTEGER NTERF
C
C  LOCAL ARRAYS
      DOUBLE PRECISION ERFCS(21)
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,DCSEVL,DERFC
      INTEGER INITDS
      EXTERNAL D1MACH,DCSEVL,DERFC,INITDS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DSIGN,DSQRT,LOG,SNGL
C
C
C SERIES FOR ERF        ON THE INTERVAL  0.          TO  1.00000E+00
C                                        WITH WEIGHTED ERROR   1.28E-32
C                                         LOG WEIGHTED ERROR  31.89
C                               SIGNIFICANT FIGURES REQUIRED  31.05
C                                    DECIMAL PLACES REQUIRED  32.55
C
      DATA ERF CS(  1) / -.4904612123 4691808039 9845440333 76 D-1     /
      DATA ERF CS(  2) / -.1422612051 0371364237 8247418996 31 D+0     /
      DATA ERF CS(  3) / +.1003558218 7599795575 7546767129 33 D-1     /
      DATA ERF CS(  4) / -.5768764699 7674847650 8270255091 67 D-3     /
      DATA ERF CS(  5) / +.2741993125 2196061034 4221607914 71 D-4     /
      DATA ERF CS(  6) / -.1104317550 7344507604 1353812959 05 D-5     /
      DATA ERF CS(  7) / +.3848875542 0345036949 9613114981 74 D-7     /
      DATA ERF CS(  8) / -.1180858253 3875466969 6317518015 81 D-8     /
      DATA ERF CS(  9) / +.3233421582 6050909646 4029309533 54 D-10    /
      DATA ERF CS( 10) / -.7991015947 0045487581 6073747085 95 D-12    /
      DATA ERF CS( 11) / +.1799072511 3961455611 9672454866 34 D-13    /
      DATA ERF CS( 12) / -.3718635487 8186926382 3168282094 93 D-15    /
      DATA ERF CS( 13) / +.7103599003 7142529711 6899083946 66 D-17    /
      DATA ERF CS( 14) / -.1261245511 9155225832 4954248533 33 D-18    /
      DATA ERF CS( 15) / +.2091640694 1769294369 1705002666 66 D-20    /
      DATA ERF CS( 16) / -.3253973102 9314072982 3641600000 00 D-22    /
      DATA ERF CS( 17) / +.4766867209 7976748332 3733333333 33 D-24    /
      DATA ERF CS( 18) / -.6598012078 2851343155 1999999999 99 D-26    /
      DATA ERF CS( 19) / +.8655011469 9637626197 3333333333 33 D-28    /
      DATA ERF CS( 20) / -.1078892517 7498064213 3333333333 33 D-29    /
      DATA ERF CS( 21) / +.1281188399 3017002666 6666666666 66 D-31    /
C
      DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 /
      DATA NTERF, XBIG, SQEPS / 0, 2*0.D0 /
C
      IF (NTERF.NE.0) GO TO 10
      NTERF = INITDS (ERFCS, 21, 0.1*SNGL(D1MACH(3)))
      XBIG = DSQRT (-LOG(SQRTPI*D1MACH(3)))
      SQEPS = DSQRT (2.0D0*D1MACH(3))
C
 10   Y = ABS(X)
      IF (Y.GT.1.D0) GO TO 20
C
C ERF(X) = 1.0 - ERFC(X)  FOR  -1.0 .LE. X .LE. 1.0
C
      IF (Y.LE.SQEPS) THEN
         DERF = 2.0D0*X*X/SQRTPI
      ELSE
         DERF = X*(1.0D0+DCSEVL(2.D0*X*X-1.D0,ERFCS,NTERF))
      END IF
C
      RETURN
C
C ERF(X) = 1.0 - ERFC(X) FOR ABS(X) .GT. 1.0
C
 20   IF (Y.LE.XBIG) THEN
         DERF = DSIGN (1.0D0-DERFC(Y), X)
      ELSE
         DERF = DSIGN (1.0D0, X)
      END IF
C
      RETURN
      END
*DFAULT
      SUBROUTINE DFAULT(IV, V)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C
C  VARIABLE DECLARATIONS
C
C  ARRAY ARGUMENTS
      REAL
     +   V(*)
      INTEGER
     +   IV(*)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   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     REAL V(45)
C/+
C     REAL MAX
C/
C     EXTERNAL IMDCON, RMDCON
C     INTEGER IMDCON
C     REAL RMDCON
C
C     REAL 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
      DATA ONE/1.0E0/, THREE/3.0E0/
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.0E-20
      IF (MACHEP .GT. 1.0E-10) V(AFCTOL) = MACHEP**2
      V(COSMIN) = MAX(1.0E-6, 1.0E2 * MACHEP)
      V(DECFAC) = 0.5E0
      SQTEPS = RMDCON(4)
      V(DELTA0) = SQTEPS
      V(DFAC) = 0.6E0
      V(DINIT) = 0.0E0
      MEPCRT = MACHEP ** (ONE/THREE)
      V(DLTFDC) = MEPCRT
      V(DLTFDJ) = SQTEPS
      V(D0INIT) = 1.0E0
      V(EPSLON) = 0.1E0
      V(FUZZ) = 1.5E0
      V(INCFAC) = 2.0E0
      V(JTINIT) = 1.0E-6
      V(LMAX0) = 100.0E0
      V(PHMNFC) = -0.1E0
      V(PHMXFC) = 0.1E0
      V(RDFCMN) = 0.1E0
      V(RDFCMX) = 4.0E0
      V(RFCTOL) = MAX(1.0E-10, MEPCRT**2)
      V(RLIMIT) = RMDCON(5)
      V(TUNER1) = 0.1E0
      V(TUNER2) = 1.0E-4
      V(TUNER3) = 0.75E0
      V(TUNER4) = 0.5E0
      V(TUNER5) = 0.75E0
      V(XCTOL) = SQTEPS
      V(XFTOL) = 1.0E2 * MACHEP
C
      RETURN
C  ***  LAST CARD OF DFAULT FOLLOWS  ***
      END
*DFBW
      SUBROUTINE DFBW (N, LAG, W, LW, DF, BW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES AND STORES THE ASSOCIATED DEGREES OF
C     FREEDOM AND BANDWIDTH FOR A GIVEN LAG WINDOW.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   BW,DF
      INTEGER
     +   LAG,LW,N
C
C  ARRAY ARGUMENTS
      REAL
     +   W(LW)
C
C  LOCAL SCALARS
      INTEGER
     +   K
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL BW
C        THE BANDWIDTH.
C     REAL DF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     INTEGER K
C        AN INDEX VARIABLE
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES.
C     REAL W(LW)
C        THE VECTOR OF LAG WINDOWS.
C
      BW = 0.0E0
      DO 10 K = 1, LAG
         BW = BW + W(K+1) * W(K+1) * (N-K)
   10 CONTINUE
C
      BW = 1.0E0 / (W(1)*W(1) + 2.0E0*BW/N)
      DF = 2.0E0 * BW * N
      RETURN
      END
*DFBWM
      SUBROUTINE DFBWM (N, LAG, W, LW, NLPPA1, NLPPA2, LNLPPA, DF, BW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES AND STORES THE ASSOCIATED DEGREES OF
C     FREEDOM AND BANDWIDTH FOR A GIVEN LAG WINDOW WHEN MISSING DATA 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  -  DECEMBER 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   BW,DF
      INTEGER
     +   LAG,LNLPPA,LW,N
C
C  ARRAY ARGUMENTS
      REAL
     +   W(LW)
      INTEGER
     +   NLPPA1(LNLPPA),NLPPA2(LNLPPA)
C
C  LOCAL SCALARS
      INTEGER
     +   K
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL BW
C        THE BANDWIDTH.
C     REAL DF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     INTEGER K
C        AN INDEX VARIABLE
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NLPPA1(LNLPPA), NLPPA2(LNLPPA)
C        THE NUMBER OF LAGGED PRODUCT PAIRS USED FOR EACH ACVF
C        ESTIMATE.
C     REAL W(LW)
C        THE VECTOR OF LAG WINDOWS.
C
      BW = (W(1)*N)**2/NLPPA1(1)
      DO 10 K = 1, LAG
         BW = BW + (W(K+1)*(N-K))**2 *
     +      (1.0E0/NLPPA1(K+1) + 1.0E0/NLPPA2(K+1))
   10 CONTINUE
C
C
      BW = N / BW
      DF = 2.0E0 * BW * N
      RETURN
      END
*DGAMI
      DOUBLE PRECISION FUNCTION DGAMI (A, X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C EVALUATE THE INCOMPLETE GAMMA FUNCTION DEFINED BY
C
C GAMI = INTEGRAL FROM T = 0 TO X OF EXP(-T) * T**(A-1.0) .
C
C GAMI IS EVALUATED FOR POSITIVE VALUES OF A AND NON-NEGATIVE VALUES
C OF X.  A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR
C WHEN GAMI IS VERY LARGE OR VERY SMALL, BECAUSE LOGARITHMIC VARIABLES
C ARE USED.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION A,X
C
C  LOCAL SCALARS
      DOUBLE PRECISION FACTOR
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,DGAMIT,DLNGAM
      EXTERNAL D1MACH,DGAMIT,DLNGAM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP,LOG
C
C
      IF (A.LE.0.D0) CALL XERROR ('DGAMI   A MUST BE GT ZERO', 25, 1,2)
      IF (X.LT.0.D0) CALL XERROR ('DGAMI   X MUST BE GE ZERO', 25, 2,2)
C
      DGAMI = 0.D0
      IF (X.EQ.0.0D0) RETURN
C
C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW.
C
      FACTOR = DLNGAM(A) + A*LOG(X)
      IF (FACTOR.GT.LOG(D1MACH(2))) THEN
         DGAMI = D1MACH(2)
      ELSE
         DGAMI = EXP(FACTOR) * DGAMIT(A,X)
      END IF
C
      RETURN
      END
*DGAMIT
      DOUBLE PRECISION FUNCTION DGAMIT (A, X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C EVALUATE TRICOMI-S INCOMPLETE GAMMA FUNCTION DEFINED BY
C
C GAMIT = X**(-A)/GAMMA(A) * INTEGRAL T = 0 TO X OF EXP(-T) * T**(A-1.)
C
C AND ANALYTIC CONTINUATION FOR A .LE. 0.0.  GAMMA(X) IS THE COMPLETE
C GAMMA FUNCTION OF X.  GAMIT IS EVALUATED FOR ARBITRARY REAL VALUES OF
C A AND FOR NON-NEGATIVE VALUES OF X (EVEN THOUGH GAMIT IS DEFINED FOR
C X .LT. 0.0), EXCEPT THAT FOR X = 0 AND A .LE. 0.0, GAMIT IS INFINITE,
C A FATAL ERROR.
C
C      A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR WHEN
C GAMIT IS VERY LARGE OR VERY SMALL IN ABSOLUTE VALUE, BECAUSE LOG-
C ARITHMIC VARIABLES ARE USED.  ALSO, IF THE PARAMETER A IS VERY CLOSE
C TO A NEGATIVE INTEGER (BUT NOT A NEGATIVE INTEGER), THERE IS A LOSS
C OF ACCURACY, WHICH IS REPORTED IF THE RESULT IS LESS THAN HALF
C MACHINE PRECISION.
C
C REF. -- W. GAUTSCHI, AN EVALUATION PROCEDURE FOR INCOMPLETE GAMMA
C FUNCTIONS, ACM TRANS. MATH. SOFTWARE.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION A,X
C
C  LOCAL SCALARS
      DOUBLE PRECISION AEPS,AINTA,ALGAP1,ALNEPS,ALNG,ALX,BOT,H,SGA,
     +   SGNGAM,SQEPS,T
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,D9GMIT,D9LGIC,D9LGIT,DGAMR,DLNGAM
      EXTERNAL D1MACH,D9GMIT,D9LGIC,D9LGIT,DGAMR,DLNGAM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DLGAMS,XERCLR,XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DSIGN,DSQRT,EXP,INT,LOG
C
C
      DATA ALNEPS, SQEPS, BOT / 3*0.D0 /
C
      IF (ALNEPS.NE.0.D0) GO TO 10
      ALNEPS = -LOG (D1MACH(3))
      SQEPS = DSQRT (D1MACH(4))
      BOT = LOG (D1MACH(1))
C
 10   IF (X.LT.0.D0) CALL XERROR ('DGAMIT  X IS NEGATIVE', 21, 2, 2)
C
      IF (X.NE.0.D0) ALX = LOG (X)
      SGA = 1.0D0
      IF (A.NE.0.D0) SGA = DSIGN (1.0D0, A)
      AINTA = INT (A + 0.5D0*SGA)
      AEPS = A - AINTA
C
      IF (X.GT.0.D0) GO TO 20
      DGAMIT = 0.0D0
      IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0)
      RETURN
C
 20   IF (X.GT.1.D0) GO TO 30
      IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1,
     1  SGNGAM)
      DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX)
      RETURN
C
 30   IF (A.LT.X) GO TO 40
      T = D9LGIT (A, X, DLNGAM(A+1.0D0))
      IF (T.LT.BOT) CALL XERCLR
      DGAMIT = EXP (T)
      RETURN
C
 40   ALNG = D9LGIC (A, X, ALX)
C
C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X))
C
      H = 1.0D0
      IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50
C
      CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM)
      T = LOG (ABS(A)) + ALNG - ALGAP1
      IF (T.GT.ALNEPS) GO TO 60
C
      IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T)
      IF (ABS(H).GT.SQEPS) GO TO 50
C
      CALL XERCLR
      CALL XERROR ('DGAMIT  RESULT LT HALF PRECISION', 32, 1, 1)
C
 50   T = -A*ALX + LOG(ABS(H))
      IF (T.LT.BOT) CALL XERCLR
      DGAMIT = DSIGN (EXP(T), H)
      RETURN
C
 60   T = T - A*ALX
      IF (T.LT.BOT) CALL XERCLR
      DGAMIT = -SGA * SGNGAM * EXP(T)
      RETURN
C
      END
*DGAMLM
      SUBROUTINE DGAMLM (XMIN, XMAX)
C JUNE 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C CALCULATE THE MINIMUM AND MAXIMUM LEGAL BOUNDS FOR X IN GAMMA(X).
C XMIN AND XMAX ARE NOT THE ONLY BOUNDS, BUT THEY ARE THE ONLY NON-
C TRIVIAL ONES TO CALCULATE.
C
C             OUTPUT ARGUMENTS --
C XMIN   DBLE PREC MINIMUM LEGAL VALUE OF X IN GAMMA(X).  ANY SMALLER
C        VALUE OF X MIGHT RESULT IN UNDERFLOW.
C XMAX   DBLE PREC MAXIMUM LEGAL VALUE OF X IN GAMMA(X).  ANY LARGER
C        VALUE OF X MIGHT CAUSE OVERFLOW.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION XMAX,XMIN
C
C  LOCAL SCALARS
      DOUBLE PRECISION ALNBIG,ALNSML,XLN,XOLD
      INTEGER I
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH
      EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG,MAX
C
C
      ALNSML = LOG(D1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = LOG(XMIN)
        XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML)
     1    / (XMIN*XLN+0.5D0)
        IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20
 10   CONTINUE
      CALL XERROR ('DGAMLM  UNABLE TO FIND XMIN', 27, 1, 2)
C
 20   XMIN = -XMIN + 0.01D0
C
      ALNBIG = LOG (D1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = LOG(XMAX)
        XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG)
     1    / (XMAX*XLN-0.5D0)
        IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40
 30   CONTINUE
      CALL XERROR ('DGAMLM  UNABLE TO FIND XMAX', 27, 2, 2)
C
 40   XMAX = XMAX - 0.01D0
      XMIN = MAX (XMIN, -XMAX+1.D0)
C
      RETURN
      END
*DGAMMA
      DOUBLE PRECISION FUNCTION DGAMMA (X)
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
C
C  LOCAL SCALARS
      DOUBLE PRECISION DXREL,PI,SINPIY,SQ2PIL,XMAX,XMIN,Y
      INTEGER I,N,NGAM
C
C  LOCAL ARRAYS
      DOUBLE PRECISION GAMCS(42)
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,D9LGMC,DCSEVL
      INTEGER INITDS
      EXTERNAL D1MACH,D9LGMC,DCSEVL,INITDS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DGAMLM,XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DBLE,DSQRT,EXP,FLOAT,INT,LOG,SIN,SNGL
C
C
C SERIES FOR GAM        ON THE INTERVAL  0.          TO  1.00000E+00
C                                        WITH WEIGHTED ERROR   5.79E-32
C                                         LOG WEIGHTED ERROR  31.24
C                               SIGNIFICANT FIGURES REQUIRED  30.00
C                                    DECIMAL PLACES REQUIRED  32.05
C
      DATA GAM CS(  1) / +.8571195590 9893314219 2006239994 2 D-2      /
      DATA GAM CS(  2) / +.4415381324 8410067571 9131577165 2 D-2      /
      DATA GAM CS(  3) / +.5685043681 5993633786 3266458878 9 D-1      /
      DATA GAM CS(  4) / -.4219835396 4185605010 1250018662 4 D-2      /
      DATA GAM CS(  5) / +.1326808181 2124602205 8400679635 2 D-2      /
      DATA GAM CS(  6) / -.1893024529 7988804325 2394702388 6 D-3      /
      DATA GAM CS(  7) / +.3606925327 4412452565 7808221722 5 D-4      /
      DATA GAM CS(  8) / -.6056761904 4608642184 8554829036 5 D-5      /
      DATA GAM CS(  9) / +.1055829546 3022833447 3182350909 3 D-5      /
      DATA GAM CS( 10) / -.1811967365 5423840482 9185589116 6 D-6      /
      DATA GAM CS( 11) / +.3117724964 7153222777 9025459316 9 D-7      /
      DATA GAM CS( 12) / -.5354219639 0196871408 7408102434 7 D-8      /
      DATA GAM CS( 13) / +.9193275519 8595889468 8778682594 0 D-9      /
      DATA GAM CS( 14) / -.1577941280 2883397617 6742327395 3 D-9      /
      DATA GAM CS( 15) / +.2707980622 9349545432 6654043308 9 D-10     /
      DATA GAM CS( 16) / -.4646818653 8257301440 8166105893 3 D-11     /
      DATA GAM CS( 17) / +.7973350192 0074196564 6076717535 9 D-12     /
      DATA GAM CS( 18) / -.1368078209 8309160257 9949917230 9 D-12     /
      DATA GAM CS( 19) / +.2347319486 5638006572 3347177168 8 D-13     /
      DATA GAM CS( 20) / -.4027432614 9490669327 6657053469 9 D-14     /
      DATA GAM CS( 21) / +.6910051747 3721009121 3833697525 7 D-15     /
      DATA GAM CS( 22) / -.1185584500 2219929070 5238712619 2 D-15     /
      DATA GAM CS( 23) / +.2034148542 4963739552 0102605193 2 D-16     /
      DATA GAM CS( 24) / -.3490054341 7174058492 7401294910 8 D-17     /
      DATA GAM CS( 25) / +.5987993856 4853055671 3505106602 6 D-18     /
      DATA GAM CS( 26) / -.1027378057 8722280744 9006977843 1 D-18     /
      DATA GAM CS( 27) / +.1762702816 0605298249 4275966074 8 D-19     /
      DATA GAM CS( 28) / -.3024320653 7353062609 5877211204 2 D-20     /
      DATA GAM CS( 29) / +.5188914660 2183978397 1783355050 6 D-21     /
      DATA GAM CS( 30) / -.8902770842 4565766924 4925160106 6 D-22     /
      DATA GAM CS( 31) / +.1527474068 4933426022 7459689130 6 D-22     /
      DATA GAM CS( 32) / -.2620731256 1873629002 5732833279 9 D-23     /
      DATA GAM CS( 33) / +.4496464047 8305386703 3104657066 6 D-24     /
      DATA GAM CS( 34) / -.7714712731 3368779117 0390152533 3 D-25     /
      DATA GAM CS( 35) / +.1323635453 1260440364 8657271466 6 D-25     /
      DATA GAM CS( 36) / -.2270999412 9429288167 0231381333 3 D-26     /
      DATA GAM CS( 37) / +.3896418998 0039914493 2081663999 9 D-27     /
      DATA GAM CS( 38) / -.6685198115 1259533277 9212799999 9 D-28     /
      DATA GAM CS( 39) / +.1146998663 1400243843 4761386666 6 D-28     /
      DATA GAM CS( 40) / -.1967938586 3451346772 9510399999 9 D-29     /
      DATA GAM CS( 41) / +.3376448816 5853380903 3489066666 6 D-30     /
      DATA GAM CS( 42) / -.5793070335 7821357846 2549333333 3 D-31     /
C
      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
C SQ2PIL IS 0.5*LOG(2*PI) = LOG(SQRT(2*PI))
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
      DATA NGAM, XMIN, XMAX, DXREL / 0, 3*0.D0 /
C
      IF (NGAM.NE.0) GO TO 10
      NGAM = INITDS (GAMCS, 42, 0.1*SNGL(D1MACH(3)) )
C
      CALL DGAMLM (XMIN, XMAX)
      DXREL = DSQRT (D1MACH(4))
C
 10   Y = ABS(X)
      IF (Y.GT.10.D0) GO TO 50
C
C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND.  REDUCE INTERVAL AND FIND
C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL.
C
      N = X
      IF (X.LT.0.D0) N = N - 1
      Y = X - DBLE(FLOAT(N))
      N = N - 1
      DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
C COMPUTE GAMMA(X) FOR X .LT. 1.0
C
      N = -N
      IF (X.EQ.0.D0) CALL XERROR ('DGAMMA  X IS 0', 14, 4, 2)
      IF (X.LT.0.0 .AND. X+DBLE(FLOAT(N-2)).EQ.0.D0) CALL XERROR (
     1  'DGAMMA  X IS A NEGATIVE INTEGER', 31, 4, 2)
      IF (X.LT.(-0.5D0) .AND. ABS((X-INT(X-0.5D0))/X).LT.DXREL) CALL
     1  XERROR (  'DGAMMA  ANSWER LT HALF PRECISION BECAUSE X TOO NEAR N
     2EGATIVE INTEGER', 68, 1, 1)
C
      DO 20 I=1,N
        DGAMMA = DGAMMA/(X+DBLE(FLOAT(I-1)) )
 20   CONTINUE
      RETURN
C
C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0
C
 30   DO 40 I=1,N
        DGAMMA = (Y+DBLE(FLOAT(I))) * DGAMMA
 40   CONTINUE
      RETURN
C
C GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
C
 50   IF (X.GT.XMAX) CALL XERROR ('DGAMMA  X SO BIG GAMMA OVERFLOWS',
     1  32, 3, 2)
C
      DGAMMA = 0.D0
      IF (X.LT.XMIN) CALL XERROR ('DGAMMA  X SO SMALL GAMMA UNDERFLOWS',
     1  35, 2, 1)
      IF (X.LT.XMIN) RETURN
C
      DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) )
      IF (X.GT.0.D0) RETURN
C
      IF (ABS((X-INT(X-0.5D0))/X).LT.DXREL) CALL XERROR (
     1  'DGAMMA  ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER',
     2  61, 1, 1)
C
      SINPIY = SIN (PI*Y)
      IF (SINPIY.EQ.0.D0) CALL XERROR (
     1  'DGAMMA  X IS A NEGATIVE INTEGER', 31, 4, 2)
C
      DGAMMA = -PI/(Y*SINPIY*DGAMMA)
C
      RETURN
      END
*DGAMR
      DOUBLE PRECISION FUNCTION DGAMR (X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C THIS ROUTINE, NOT DGAMMA(X), SHOULD BE THE FUNDAMENTAL ONE.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
C
C  LOCAL SCALARS
      DOUBLE PRECISION ALNGX,SGNGX
      INTEGER IROLD
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION DGAMMA
      EXTERNAL DGAMMA
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DLGAMS,XERCLR,XGETF,XSETF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,EXP,INT
C
C
      DGAMR = 0.0D0
      IF (X.LE.0.0D0 .AND. INT(X).EQ.X) RETURN
C
      CALL XGETF (IROLD)
      CALL XSETF (1)
      IF (ABS(X).GT.10.0D0) GO TO 10
      DGAMR = 1.0D0/DGAMMA(X)
      CALL XERCLR
      CALL XSETF (IROLD)
      RETURN
C
 10   CALL DLGAMS (X, ALNGX, SGNGX)
      CALL XERCLR
      CALL XSETF (IROLD)
      DGAMR = SGNGX * EXP(-ALNGX)
      RETURN
C
      END
*DIFC
      SUBROUTINE DIFC (Y, N, NFAC, ND, IOD, IAR, PHI, LPHI, YF, NYF,
     +   LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE EXPANDS THE DIFFERENCE FILTER SPECIFIED BY NFAC,
C     IOD AND ND INTO PHI AND PERFORMS THE DIFFERENCE FILTERING
C     OPERATION DEFINED BY PHI, RETURNING THE FILTERED SERIES
C     IN YF.
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
     +   IAR,LDSTAK,LPHI,N,NFAC,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   PHI(*),Y(*),YF(*)
      INTEGER
     +   IOD(*),ND(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,LDSMIN,NALL0,WORK
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      CHARACTER
     +   LLDS(8)*1,LLPHI(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCOEF,EISGE,ERDF,FLTAR,IPRINT,LDSCMP,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      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     LOGICAL ERR01, ERR02, ERR03, ERR04
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 IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
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 IOD(NFAC)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
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 LLDS(8), LLPHI(8), LN(8)
C        THE ARRAYS CONTAINING THE NAMES OF VARIOUS VARIABLES
C     INTEGER LPHI
C        THE LENGTH OF THE ARRAY PHI.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES Y.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING WORK AREA ALLOCATIONS.
C     INTEGER ND(NFAC)
C        THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE
C        FACTORS ARE TO BE APPLIED.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS.
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     REAL PHI(LPHI)
C        THE VECTOR CONTAINING THE FILTER COEFFICIENTS.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER WORK
C        THE STARTING LOCATION FOR THE WORK VECTOR NECESSARY TO
C        EXPAND THE DIFFERENCE FILTER.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'D',       'I',       'F',       'C',       ' ',       ' '/
      DATA
     +  LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +  LLDS(7), LLDS(8)
     + /  'L',   'D',   'S',   'T',   'A',   'K',   ' ',   ' '/
      DATA
     +  LLPHI(1), LLPHI(2), LLPHI(3), LLPHI(4), LLPHI(5), LLPHI(6),
     +  LLPHI(7), LLPHI(8)
     + /  'L',   'P',   'H',   'I',   ' ',   ' ',   ' ',   ' '/
      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
      ERR01 = .FALSE.
      ERR02 = .FALSE.
      ERR03 = .FALSE.
      ERR04 = .FALSE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB,LN,N,3,1,HEAD,ERR01,LN)
C
      IAR = 0
C
      IF (NFAC.GE.1) THEN
C
         DO 10 I = 1, NFAC
            IAR = IAR + ND(I)*IOD(I)
   10    CONTINUE
C
         CALL ERDF(NMSUB,NFAC,ND,IOD,N,HEAD,ERR02)
C
         IF (.NOT.ERR02) THEN
            CALL EISGE(NMSUB,LLPHI,LPHI,IAR,9,HEAD,ERR03,LLPHI)
            CALL LDSCMP(1,0,0,0,0,0,'S',2*IAR,LDSMIN)
            CALL EISGE(NMSUB,LLDS,LDSTAK,LDSMIN,9,HEAD,ERR04,LLDS)
         END IF
      END IF
C
C
      IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 20
      GO TO 30
C
   20 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   30 CONTINUE
C
      NYF = N
      DO 50 I = 1, NYF
         YF(I) = Y(I)
   50 CONTINUE
C
      IF (NFAC .LE. 0) RETURN
C
      CALL STKSET (LDSTAK, 4)
      NALL0 = STKST(1)
C
      DO 60 I = 1, LPHI
         PHI(I) = 0.0E0
   60 CONTINUE
C
      WORK = STKGET(2*IAR, 3)
C
      IF (IERR .EQ. 1) GO TO 20
C
      CALL DCOEF (NFAC,ND,IOD,IAR,PHI,LPHI,RSTAK(WORK))
C
      CALL STKCLR(NALL0)
C
      IF (IERR .EQ. 1) GO TO 20
C
      CALL FLTAR (YF,NYF,IAR,PHI,YF,NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL DIFC (Y, N,'/
     +   '      +           NFAC, ND, IOD, IAR, PHI, LPHI,'/
     +   '      +           YF, NYF, LDSTAK)')
      END
*DIF
      SUBROUTINE DIF (Y, N, YF, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PERFORMS A FIRST DIFFERENCE FILTERING OPERATION,
C     RETURNING THE FILTERED SERIES IN YF.
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
     +   N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IAR,IPRT
      LOGICAL
     +   ERR01,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   PHI(1)
      CHARACTER
     +   LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,FLTAR,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01
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 IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
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     CHARACTER*1 LN(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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     REAL PHI(1)
C        THE VECTOR CONTAINING THE FILTER COEFFICIENTS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'D',       'I',       'F',       ' ',       ' ',       ' '/
      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
C
      IF (.NOT. ERR01) GO TO 10
C
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      IAR = 1
      PHI(1) = 1.0E0
C
      CALL FLTAR (Y, N, IAR, PHI, YF, NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   31H       CALL DIF (Y, N, YF, NYF))
      END
*DIFMC
      SUBROUTINE DIFMC (Y, YMISS, N, NFAC, ND, IOD, IAR, PHI, LPHI, YF,
     +   YFMISS, NYF, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE EXPANDS THE DIFFERENCE FILTER SPECIFIED BY NFAC,
C     IOD AND ND INTO PHI AND PERFORMS THE DIFFERENCE FILTERING
C     OPERATION DEFINED BY PHI ON A SERIES CONTAINING MISSING DATA,
C     RETURNING THE FILTERED SERIES IN YF.
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
      REAL
     +   YFMISS,YMISS
      INTEGER
     +   IAR,LDSTAK,LPHI,N,NFAC,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   PHI(*),Y(*),YF(*)
      INTEGER
     +   IOD(*),ND(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,LDSMIN,NALL0,WORK
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      CHARACTER
     +   LLDS(8)*1,LLPHI(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCOEF,EISGE,ERDF,FLTARM,IPRINT,LDSCMP,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      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     LOGICAL ERR01, ERR02, ERR03, ERR04
C        VALUES 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 IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
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 IOD(NFAC)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
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 LLDS(8), LLPHI(8), LN(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES LDSTAK, N
C        AND LPHI, RESPECTIVELY.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES Y.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C     INTEGER ND(NFAC)
C        THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE
C        FACTORS ARE TO BE APPLIED.
C     INTEGER NFAC
C        THE NUMBER OF DIFFERENCE FACTORS.
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     REAL PHI(LPHI)
C        THE VECTOR CONTAINING THE FILTER COEFFICIENTS.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER WORK
C        THE STARTING LOCATION FOR THE WORK VECTOR NECESSARY TO
C        EXPAND THE DIFFERENCE FILTER.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C     REAL YFMISS
C        THE MISSING VALUE CODE USED IN THE FILTERED SERIES TO
C        INDICATE THE VALUE COULD NOT BE COMPUTED DUE TO MISSING DATA.
C     REAL YMISS
C        THE MISSING VALUE CODE USED IN THE INPUT SERIES TO INDICATE
C        AN OBSERVATION IS MISSING.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'D',       'I',       'F',       'M',       'C',       ' '/
      DATA
     +  LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +  LLDS(7), LLDS(8)
     + /  'L',   'D',   'S',   'T',   'A',   'K',   ' ',   ' '/
      DATA
     +  LLPHI(1), LLPHI(2), LLPHI(3), LLPHI(4), LLPHI(5), LLPHI(6),
     +  LLPHI(7), LLPHI(8)
     + /  'L',   'P',   'H',   'I',   ' ',   ' ',   ' ',   ' '/
      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
      ERR01 = .FALSE.
      ERR02 = .FALSE.
      ERR03 = .FALSE.
      ERR04 = .FALSE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB,LN,N,3,1,HEAD,ERR01,LN)
C
      IAR = 0
C
      IF (NFAC.GE.1) THEN
C
         DO 10 I = 1, NFAC
            IAR = IAR + ND(I)*IOD(I)
   10    CONTINUE
C
         CALL ERDF(NMSUB,NFAC,ND,IOD,N,HEAD,ERR02)
C
         IF (.NOT.ERR02) THEN
            CALL EISGE(NMSUB,LLPHI,LPHI,IAR,9,HEAD,ERR03,LLPHI)
            CALL LDSCMP(1,0,0,0,0,0,'S',2*IAR,LDSMIN)
            CALL EISGE(NMSUB,LLDS,LDSTAK,LDSMIN,9,HEAD,ERR04,LLDS)
         END IF
      END IF
C
      IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 20
      GO TO 30
C
   20 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   30 CONTINUE
C
      NYF = N
      DO 50 I = 1, NYF
         YF(I) = Y(I)
   50 CONTINUE
C
      YFMISS = YMISS
C
      IF (NFAC .LE. 0) RETURN
C
      CALL STKSET (LDSTAK, 4)
      NALL0 = STKST(1)
C
      DO 60 I = 1, LPHI
         PHI(I) = 0.0E0
   60 CONTINUE
C
      WORK = STKGET(2*IAR,3)
C
      IF (IERR .EQ. 1) GO TO 20
C
      CALL DCOEF (NFAC,ND,IOD,IAR,PHI,LPHI,RSTAK(WORK))
C
      CALL STKCLR(NALL0)
C
      IF (IERR .EQ. 1) GO TO 20
C
      CALL FLTARM (YF,YMISS,NYF,IAR,PHI,YF,YFMISS,NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL DIFMC (Y, YMISS, N,'/
     +   '      +            NFAC, ND, IOD, IAR, PHI, LPHI,'/
     +   '      +            YF, YFMISS, NYF, LDSTAK)')
      END
*DIFM
      SUBROUTINE DIFM (Y, YMISS, N, YF, YFMISS, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PERFORMS A FIRST DIFFERENCE FILTERING OPERATION,
C     RETURNING THE FILTERED SERIES IN YF, FOR AN INPUT SERIES
C     CONTAINING MISSING VALUES.
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
      REAL
     +   YFMISS,YMISS
      INTEGER
     +   N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IAR,IPRT
      LOGICAL
     +   ERR01,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   PHI(1)
      CHARACTER
     +   LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,FLTARM,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01
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 IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
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     CHARACTER*1 LN(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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     REAL PHI(1)
C        THE VECTOR CONTAINING THE FILTER COEFFICIENTS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C     REAL YFMISS
C        THE MISSING VALUE CODE USED IN THE FILTERED SERIES TO
C        INDICATE THE VALUE COULD NOT BE COMPUTED DUE TO MISSING DATA.
C     REAL YMISS
C        THE MISSING VALUE CODE USED IN THE INPUT SERIES TO INDICATE
C        AN OBSERVATION IS MISSING.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'D',       'I',       'F',       'M',       ' ',       ' '/
      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
      IF (.NOT. ERR01) GO TO 10
C
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      IAR = 1
      PHI(1) = 1.0E0
C
      CALL FLTARM (Y, YMISS, N, IAR, PHI, YF, YFMISS, NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   47H       CALL DIFM (Y, YMISS, N, YF, YFMISS, NYF))
      END
*DIFSER
      SUBROUTINE DIFSER (Y, N, NDF, ND, IOD, YDIFF, NDIFF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PERFORMS THE DIFFERENCING OPPERATION
C     DEFINED BY ND, IOD AND NDF ON THE SERIES Y, RESULTING IN
C     THE SERIES YDIFF.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVIAION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 21, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NDF,NDIFF
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YDIFF(*)
      INTEGER
     +   IOD(*),ND(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J,K,L,NTIMES
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IOD(NDF)
C        THE VECTOR CONTAINING THE ORDERS OF EACH DIFFERENCE FACTOR.
C     INTEGER J, K, L
C        INDEX VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER ND(NDF)
C        THE VECTOR CONTAINING THE NUMBER OF TIMES EACH DIFFERENCING
C        FACTOR IS APPLIED.
C     INTEGER NDF
C        THE NUMBER OF DIFFERENCE FACTORS.
C     INTEGER NDIFF
C        THE NUMBER OF OBSERVATIONS REMAINING IN THE DIFFERENCED SERIES.
C     INTEGER NTIMES
C        THE NUMBER OF TIMES A GIVEN DIFFERENCE FACTOR IS TO BE APPLIED.
C     REAL Y(N), YDIFF(N)
C        THE VECTOR CONTAINING THE SERIES OBSERVATIONS AND THE VECTOR
C        IN WHICH THE DIFFERENCED SERIES IS RETURNED.
C
      DO 10 I = 1, N
         YDIFF(I) = Y(I)
   10 CONTINUE
C
      NDIFF = N
C
      IF (NDF .EQ. 0) RETURN
C
      DO 40 I = 1, NDF
         NTIMES = ND(I)
         DO 30 L = 1, NTIMES
            NDIFF = NDIFF - IOD(I)
            DO 20 J = 1, NDIFF
               K = J + IOD(I)
               YDIFF(J) = YDIFF(K) - YDIFF(J)
   20       CONTINUE
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*DLBETA
      DOUBLE PRECISION FUNCTION DLBETA (A, B)
C JULY 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION A,B
C
C  LOCAL SCALARS
      DOUBLE PRECISION CORR,P,Q,SQ2PIL
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D9LGMC,DGAMMA,DLNGAM,DLNREL
      EXTERNAL D9LGMC,DGAMMA,DLNGAM,DLNREL
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG,MAX,MIN
C
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
C
      P = MIN (A, B)
      Q = MAX (A, B)
C
      IF (P.LE.0.D0) CALL XERROR (
     1  'DLBETA  BOTH ARGUMENTS MUST BE GT ZERO', 38, 1, 2)
C
      IF (P.GE.10.D0) GO TO 30
      IF (Q.GE.10.D0) GO TO 20
C
C P AND Q ARE SMALL.
C
      DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) )
      RETURN
C
C P IS SMALL, BUT Q IS BIG.
C
 20   CORR = D9LGMC(Q) - D9LGMC(P+Q)
      DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q)
     1  + (Q-0.5D0)*DLNREL(-P/(P+Q))
      RETURN
C
C P AND Q ARE BIG.
C
 30   CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q)
      DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q))
     1  + Q*DLNREL(-P/(P+Q))
      RETURN
C
      END
*DLGAMS
      SUBROUTINE DLGAMS (X, DLGAM, SGNGAM)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C EVALUATE LOG ABS (GAMMA(X)) AND RETURN THE SIGN OF GAMMA(X) IN SGNGAM.
C SGNGAM IS EITHER +1.0 OR -1.0.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION DLGAM,SGNGAM,X
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT,MOD
C
C
      DLGAM = DLNGAM(X)
      SGNGAM = 1.0D0
      IF (X.GT.0.D0) RETURN
C
C     INT = DMOD (-INT(X), 2.0D0) + 0.1D0
      IF (INT(MOD(-INT(X),2)+0.1D0).EQ.0) SGNGAM = -1.0D0
C
      RETURN
      END
*DLNGAM
      DOUBLE PRECISION FUNCTION DLNGAM (X)
C JUNE 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
C
C  LOCAL SCALARS
      DOUBLE PRECISION DXREL,PI,SINPIY,SQ2PIL,SQPI2L,XMAX,Y
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,D9LGMC,DGAMMA
      EXTERNAL D1MACH,D9LGMC,DGAMMA
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DSQRT,INT,LOG,SIN
C
C
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
C SQ2PIL = LOG (SQRT(2*PI)),  SQPI2L = LOG(SQRT(PI/2))
      DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0    /
      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
C
      DATA XMAX, DXREL / 2*0.D0 /
C
      IF (XMAX.NE.0.D0) GO TO 10
      XMAX = D1MACH(2)/LOG(D1MACH(2))
      DXREL = DSQRT (D1MACH(4))
C
 10   Y = ABS (X)
      IF (Y.GT.10.D0) GO TO 20
C
C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0
C
      DLNGAM = LOG (ABS (DGAMMA(X)) )
      RETURN
C
C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0
C
 20   IF (Y.GT.XMAX) CALL XERROR (
     1  'DLNGAM  ABS(X) SO BIG DLNGAM OVERFLOWS', 39, 2, 2)
C
      IF (X.GT.0.D0) THEN
         DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y)
         RETURN
      END IF
C
      SINPIY = ABS (SIN(PI*Y))
      IF (SINPIY.EQ.0.D0) CALL XERROR (
     1  'DLNGAM  X IS A NEGATIVE INTEGER', 31, 3, 2)
C
      IF (ABS ((X-INT(X-0.5D0))/X).LT.DXREL) CALL XERROR (
     1    'DLNGAM  ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE
     2INTEGER', 68, 1, 1)
C
      DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y)
      RETURN
C
      END
*DLNREL
      DOUBLE PRECISION FUNCTION DLNREL (X)
C JUNE 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION X
C
C  LOCAL SCALARS
      DOUBLE PRECISION XMIN
      INTEGER NLNREL
C
C  LOCAL ARRAYS
      DOUBLE PRECISION ALNRCS(43)
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION D1MACH,DCSEVL
      INTEGER INITDS
      EXTERNAL D1MACH,DCSEVL,INITDS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,DSQRT,LOG,SNGL
C
C
C SERIES FOR ALNR       ON THE INTERVAL -3.75000E-01 TO  3.75000E-01
C                                        WITH WEIGHTED ERROR   6.35E-32
C                                         LOG WEIGHTED ERROR  31.20
C                               SIGNIFICANT FIGURES REQUIRED  30.93
C                                    DECIMAL PLACES REQUIRED  32.01
C
      DATA ALNRCS(  1) / +.1037869356 2743769800 6862677190 98 D+1     /
      DATA ALNRCS(  2) / -.1336430150 4908918098 7660415531 33 D+0     /
      DATA ALNRCS(  3) / +.1940824913 5520563357 9261993747 50 D-1     /
      DATA ALNRCS(  4) / -.3010755112 7535777690 3765377765 92 D-2     /
      DATA ALNRCS(  5) / +.4869461479 7154850090 4563665091 37 D-3     /
      DATA ALNRCS(  6) / -.8105488189 3175356066 8099430086 22 D-4     /
      DATA ALNRCS(  7) / +.1377884779 9559524782 9382514960 59 D-4     /
      DATA ALNRCS(  8) / -.2380221089 4358970251 3699929149 35 D-5     /
      DATA ALNRCS(  9) / +.4164041621 3865183476 3918599019 89 D-6     /
      DATA ALNRCS( 10) / -.7359582837 8075994984 2668370319 98 D-7     /
      DATA ALNRCS( 11) / +.1311761187 6241674949 1522943450 11 D-7     /
      DATA ALNRCS( 12) / -.2354670931 7742425136 6960923301 75 D-8     /
      DATA ALNRCS( 13) / +.4252277327 6034997775 6380529625 67 D-9     /
      DATA ALNRCS( 14) / -.7719089413 4840796826 1081074933 00 D-10    /
      DATA ALNRCS( 15) / +.1407574648 1359069909 2153564721 91 D-10    /
      DATA ALNRCS( 16) / -.2576907205 8024680627 5370786275 84 D-11    /
      DATA ALNRCS( 17) / +.4734240666 6294421849 1543950059 38 D-12    /
      DATA ALNRCS( 18) / -.8724901267 4742641745 3012632926 75 D-13    /
      DATA ALNRCS( 19) / +.1612461490 2740551465 7398331191 15 D-13    /
      DATA ALNRCS( 20) / -.2987565201 5665773006 7107924168 15 D-14    /
      DATA ALNRCS( 21) / +.5548070120 9082887983 0413216972 79 D-15    /
      DATA ALNRCS( 22) / -.1032461915 8271569595 1413339619 32 D-15    /
      DATA ALNRCS( 23) / +.1925023920 3049851177 8785032448 68 D-16    /
      DATA ALNRCS( 24) / -.3595507346 5265150011 1897078442 66 D-17    /
      DATA ALNRCS( 25) / +.6726454253 7876857892 1945742267 73 D-18    /
      DATA ALNRCS( 26) / -.1260262416 8735219252 0824256375 46 D-18    /
      DATA ALNRCS( 27) / +.2364488440 8606210044 9161589555 19 D-19    /
      DATA ALNRCS( 28) / -.4441937705 0807936898 8783891797 33 D-20    /
      DATA ALNRCS( 29) / +.8354659446 4034259016 2412939946 66 D-21    /
      DATA ALNRCS( 30) / -.1573155941 6479562574 8992535210 66 D-21    /
      DATA ALNRCS( 31) / +.2965312874 0247422686 1543697066 66 D-22    /
      DATA ALNRCS( 32) / -.5594958348 1815947292 1560132266 66 D-23    /
      DATA ALNRCS( 33) / +.1056635426 8835681048 1872841386 66 D-23    /
      DATA ALNRCS( 34) / -.1997248368 0670204548 3149994666 66 D-24    /
      DATA ALNRCS( 35) / +.3778297781 8839361421 0498559999 99 D-25    /
      DATA ALNRCS( 36) / -.7153158688 9081740345 0381653333 33 D-26    /
      DATA ALNRCS( 37) / +.1355248846 3674213646 5020245333 33 D-26    /
      DATA ALNRCS( 38) / -.2569467304 8487567430 0798293333 33 D-27    /
      DATA ALNRCS( 39) / +.4874775606 6216949076 4595199999 99 D-28    /
      DATA ALNRCS( 40) / -.9254211253 0849715321 1323733333 33 D-29    /
      DATA ALNRCS( 41) / +.1757859784 1760239233 2697600000 00 D-29    /
      DATA ALNRCS( 42) / -.3341002667 7731010351 3770666666 66 D-30    /
      DATA ALNRCS( 43) / +.6353393618 0236187354 1802666666 66 D-31    /
C
      DATA NLNREL, XMIN / 0, 0.D0 /
C
      IF (NLNREL.NE.0) GO TO 10
      NLNREL = INITDS (ALNRCS, 43, 0.1*SNGL(D1MACH(3)))
      XMIN = -1.0D0 + DSQRT(D1MACH(4))
C
 10   IF (X.LE.(-1.D0)) CALL XERROR ('DLNREL  X IS LE -1', 18, 2, 2)
      IF (X.LT.XMIN) CALL XERROR (
     1  'DLNREL  ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 54,
     2  1, 1)
C
      IF (ABS(X).LE.0.375D0) THEN
         DLNREL = X*(1.0D0 - X*DCSEVL (X/0.375D0, ALNRCS, NLNREL))
      ELSE
         DLNREL = LOG (1.0D0+X)
      END IF
C
      RETURN
      END
*DOTC
      SUBROUTINE DOTC (Y, YMEAN, NY, X, XMEAN, NX, DOTXY, NDOTXY)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE DOT PRODUCT OF TWO
C     SERIES, CENTERED ABOUT THEIR RESPECTIVE MEANS.
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
      REAL
     +   DOTXY,XMEAN,YMEAN
      INTEGER
     +   NDOTXY,NX,NY
C
C  ARRAY ARGUMENTS
      REAL
     +   X(NX),Y(NY)
C
C  LOCAL SCALARS
      INTEGER
     +   I,M
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DOTXY
C        THE DOT PRODUCT OF THE SERIES (Y(I) - YMEAN) AND
C        (X(I) - XMEAN).
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER M
C        THE SMALLER OF THE NUMBER OF OBSERVATIONS IN X AND Y
C     INTEGER NDOTXY
C        THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY
C     INTEGER NX, NY
C        THE NUMBER OF OBSERVATIONS IN SERIES X AND Y, RESPECTIVELY.
C     REAL X(NX)
C        THE VECTOR CONTAINING THE SECOND SERIES
C     REAL XMEAN
C        THE MEAN OF THE SECOND SERIES.
C     REAL Y(NY)
C        THE VECTOR CONTAINING THE FIRST SERIES
C     REAL YMEAN
C        THE MEAN OF THE FIRST SERIES.
C
      NDOTXY = 0
      DOTXY = 0.0E0
      M = MIN(NY, NX)
      DO 10 I = 1, M
         DOTXY = DOTXY + (Y(I) - YMEAN) * (X(I) - XMEAN)
         NDOTXY = NDOTXY + 1
   10 CONTINUE
      RETURN
      END
*DOTCM
      SUBROUTINE DOTCM (Y, YMEAN, YMISS, NY, X, XMEAN, XMISS,
     +   NX, DOTXY, NDOTXY)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE DOT PRODUCT OF TWO
C     SERIES WITH MISSING DATA, CENTERED ABOUT THEIR RESPECTIVE MEANS.
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
      REAL
     +   DOTXY,XMEAN,XMISS,YMEAN,YMISS
      INTEGER
     +   NDOTXY,NX,NY
C
C  ARRAY ARGUMENTS
      REAL
     +   X(NX),Y(NY)
C
C  LOCAL SCALARS
      INTEGER
     +   I,M
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      EXTERNAL MVCHK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DOTXY
C        THE DOT PRODUCT OF THE SERIES (Y(I) - YMEAN) AND
C        (X(I) - XMEAN).
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER M
C        THE SMALLER OF THE NUMBER OF OBSERVATIONS IN X AND Y
C     INTEGER NDOTXY
C        THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY
C     INTEGER NX, NY
C        THE NUMBER OF OBSERVATIONS IN SERIES X AND Y, RESPECTIVELY.
C     REAL X(NX)
C        THE VECTOR CONTAINING THE SECOND SERIES
C     REAL XMEAN
C        THE MEAN OF THE SECOND SERIES.
C     REAL XMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IN THE SERIES IS MISSING.  IF X(I) = XMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C     REAL Y(NY)
C        THE VECTOR CONTAINING THE FIRST SERIES
C     REAL YMEAN
C        THE MEAN OF THE FIRST SERIES.
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IN THE SERIES IS MISSING.  IF Y(I) = YMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C
      NDOTXY = 0
      DOTXY = 0.0E0
      M = MIN(NY, NX)
      DO 10 I = 1, M
         IF (MVCHK(Y(I), YMISS) .OR. MVCHK(X(I), XMISS)) GO TO 10
         DOTXY = DOTXY + (Y(I) - YMEAN) * (X(I) - XMEAN)
         NDOTXY = NDOTXY + 1
   10 CONTINUE
      RETURN
      END
*DOTPRD
      REAL 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
      REAL
     +   X(*),Y(*)
C
C  LOCAL SCALARS
      REAL
     +   ONE,SQTETA,T,ZERO
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RMDCON
      EXTERNAL RMDCON
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX
C
C     INTEGER P
C     REAL X(*), Y(*)
C
C     INTEGER I
C     REAL ONE, SQTETA, T, ZERO
C/+
C     REAL MAX, ABS
C/
C     EXTERNAL RMDCON
C     REAL RMDCON
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.0E0/, SQTETA/0.0E0/, ZERO/0.0E0/
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
*DRV1A
      SUBROUTINE DRV1A(COEF, NCOEF, XM, N, M, IXM, D)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL1
C     CODED CORRECTLY.
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,NCOEF
C
C  ARRAY ARGUMENTS
      REAL
     +   COEF(NCOEF),D(N,NCOEF),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL COEF(NCOEF)
C        MODEL COEFFICIENTS
C     REAL D(N,NCOEF)
C        THE FIRST DERIVATIVE WITH RESPECT TO THE ITH COEFFICIENT
C     INTEGER I
C        ROW MARKER
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 NCOEF
C        THE NUMBER OF COEFFICIENTS
C     REAL XM(IXM,M)
C        INDEPENDENT VARIABLES
C
C
      DO 10 I=1,N
         D(I,1) = XM(I,1)**COEF(2)
         D(I,2) = COEF(1)*(XM(I,1)**COEF(2))*LOG(XM(I,1))
   10 CONTINUE
C
      RETURN
C
      END
*DRV1B
      SUBROUTINE DRV1B(PAR, NPAR, XM, N, M, IXM, D)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL1
C     CODED INCORRECTLY.
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
      REAL
     +   D(N,NPAR),PAR(NPAR),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL D(N,NPAR)
C        THE FIRST DERIVATIVE WITH RESPECT TO THE ITH COEFFICIENT
C     INTEGER I
C        ROW MARKER
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 COEFFICIENTS
C     REAL PAR(NPAR)
C        MODEL COEFFICIENTS
C     REAL XM(IXM,M)
C        INDEPENDENT VARIABLES
C
C
      DO 10 I=1,N
         D(I,1) = XM(I,1)*PAR(2)
         D(I,2) = PAR(1)*(XM(I,1)**PAR(2))*LOG(XM(I,1))
   10 CONTINUE
C
      RETURN
C
      END
*DRV2
      SUBROUTINE DRV2(PAR, NPAR, XM, N, M, IXM, D)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL2.
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
      REAL
     +   D(N,NPAR),PAR(NPAR),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL PAR(NPAR)
C        MODEL PARAMETERS
C     REAL D(N,NPAR)
C        THE FIRST DERIVATIVE WITH RESPECT TO THE ITH PARAMETER
C     INTEGER I
C        ROW MARKER
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     REAL XM(IXM,M)
C        MODEL INDEPENDENT VARIABLE
C
C
      DO 10 I=1,N
         D(I,1) = XM(I,1)
         D(I,2) = XM(I,2)
         D(I,3) = XM(I,3)**3
   10 CONTINUE
C
      RETURN
C
      END
*DRV3
      SUBROUTINE DRV3(PAR, NPAR, XM, N, M, IXM, D)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL3
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
      REAL
     +   D(N,NPAR),PAR(NPAR),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL PAR(NPAR)
C        MODEL PARAMETERS
C     REAL D(N,NPAR)
C        THE FIRST DERIVATIVE WITH RESPECT TO THE ITH PARAMETER
C     INTEGER I
C        ROW MARKER
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     REAL XM(IXM,M)
C        INDEPENDENT VARIABLE
C
      DO 20 I=1,N
         DO 10 J=1,NPAR
            D(I,J) = XM(I,J)
   10    CONTINUE
   20 CONTINUE
C
      RETURN
C
      END
*DRV4A
      SUBROUTINE DRV4A (COEF, NCOEF, XM, N, M, IXM, D)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     DERIVATIVE FOR DERIVATIVE CHECKING ROUTINES (CORRECTLY CODED).
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,NCOEF
C
C  ARRAY ARGUMENTS
      REAL
     +   COEF(NCOEF),D(N,NCOEF),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL COEF(NCOEF)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        COEFFICIENTS ARE STORED.
C     REAL D(N,NCOEF)
C        THE MATRIX OF FIRST PARTIAL DERIVATIVES (JACOBIAN).
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NCOEF
C        THE NUMBER OF UNKNOWN COEFFICIENTS IN THE MODEL.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C
      DO 10 I = 1, N
         D(I,1) = 1.0E0
         D(I,2) = (COEF(3)*2.0E0*(XM(I,1)-COEF(2))/COEF(4)) *
     +      EXP(-((XM(I,1)-COEF(2))**2)/COEF(4))
         D(I,3) = EXP(-((XM(I,1)-COEF(2))**2)/COEF(4))
         D(I,4) = -COEF(3)*(-((XM(I,1)-COEF(2))**2) /
     +      (COEF(4)**2)) * EXP(-((XM(I,1)-COEF(2))**2)/COEF(4))
   10 CONTINUE
C
      RETURN
C
      END
*DRV4B
      SUBROUTINE DRV4B (COEF, NCOEF, XM, N, M, IXM, D)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     DERIVATIVE FOR DERIVATIVE CHECKING ROUTINES (INCORRECTLY CODED).
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,NCOEF
C
C  ARRAY ARGUMENTS
      REAL
     +   COEF(NCOEF),D(N,NCOEF),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL COEF(NCOEF)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        COEFFICIENTS ARE STORED.
C     REAL D(N,NCOEF)
C        THE MATRIX OF FIRST PARTIAL DERIVATIVES (JACOBIAN).
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NCOEF
C        THE NUMBER OF UNKNOWN COEFFICIENTS IN THE MODEL.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C
      DO 10 I = 1, N
         D(I,1) = 0.0E0
         D(I,2) = (COEF(3)*2.0E0*(XM(I,1)-COEF(2))/COEF(4)) *
     +      EXP(-((XM(I,1)-COEF(2))**2)/COEF(4))
         D(I,3) = 0.0E0
         D(I,4) = COEF(3)*(-((XM(I,1)-COEF(2))**2) /
     +      (COEF(4)**2)) * EXP(-((XM(I,1)-COEF(2))**2)/COEF(4))
   10 CONTINUE
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
      REAL
     +   D(N,NPAR),PAR(NPAR),XM(IXM,M)
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        MODEL PARAMETERS
C     REAL XM(IXM,M)
C        MODEL INDEPENDENT VARIABLE
C
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
      REAL
     +   D(P),J(NN,P),V(1)
      INTEGER
     +   IV(1)
C
C  LOCAL SCALARS
      REAL
     +   SII,T,VDFAC,ZERO
      INTEGER
     +   D0,DFAC,DTYPE,I,JTOL0,JTOLI,NITER,S,S1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   V2NORM
      EXTERNAL V2NORM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,SQRT
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER IV(1), N, NN, P
C     REAL D(P), J(NN,P), V(1)
C     DIMENSION IV(*), V(*)
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER D0, I, JTOLI, S1
C     REAL SII, T, VDFAC
C
C     ***  CONSTANTS  ***
C     REAL ZERO
C
C/
C  ***  EXTERNAL FUNCTION  ***
C
C     EXTERNAL V2NORM
C     REAL V2NORM
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.0E0/
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
*E9RINT
      SUBROUTINE E9RINT(MESSG,NW,NERR,SAVE)
C
C  THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE,
C  IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. .
C
C     CHARACTER*4 MESSG(NW)
C     LOGICAL SAVE
C
C  MESSGP STORES AT LEAST THE FIRST 72 CHARACTERS OF THE PREVIOUS
C  MESSAGE. ITS LENGTH IS MACHINE DEPENDENT AND MUST BE AT LEAST
C
C       1 + 71/(THE NUMBER OF CHARACTERS STORED PER INTEGER WORD).
C
C     CHARACTER*4 MESSGP(36),FMT(14),CCPLUS
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER NERR,NW
      LOGICAL SAVE
C
C  ARRAY ARGUMENTS
      CHARACTER MESSG(NW)*4
C
C  LOCAL SCALARS
      INTEGER I,IWUNIT,NERRP,NWP
      CHARACTER CCPLUS*4
C
C  LOCAL ARRAYS
      CHARACTER FMT(14)*4,MESSGP(36)*4
C
C  EXTERNAL FUNCTIONS
      INTEGER I1MACH,I8SAVE
      EXTERNAL I1MACH,I8SAVE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL S88FMT
C
C
C  START WITH NO PREVIOUS MESSAGE.
C
      DATA MESSGP(1)/'1'/, NWP/0/, NERRP/0/
C
C  SET UP THE FORMAT FOR PRINTING THE ERROR MESSAGE.
C  THE FORMAT IS SIMPLY (A1,14X,72AXX) WHERE XX=I1MACH(6) IS THE
C  NUMBER OF CHARACTERS STORED PER INTEGER WORD.
C
      DATA CCPLUS  / '+' /
C
      DATA FMT( 1) / '(' /
      DATA FMT( 2) / 'A' /
      DATA FMT( 3) / '1' /
      DATA FMT( 4) / ',' /
      DATA FMT( 5) / '1' /
      DATA FMT( 6) / '4' /
      DATA FMT( 7) / 'X' /
      DATA FMT( 8) / ',' /
      DATA FMT( 9) / '7' /
      DATA FMT(10) / '2' /
      DATA FMT(11) / 'A' /
      DATA FMT(12) / 'X' /
      DATA FMT(13) / 'X' /
      DATA FMT(14) / ')' /
C
      IF (.NOT.SAVE) GO TO 20
C
C  SAVE THE MESSAGE.
C
        NWP=NW
        NERRP=NERR
        DO 10 I=1,NW
 10     MESSGP(I)=MESSG(I)
C
        GO TO 30
C
 20   IF (I8SAVE(1,0,.FALSE.).EQ.0) GO TO 30
C
C  PRINT THE MESSAGE.
C
        IWUNIT=I1MACH(4)
        WRITE(IWUNIT,9000) NERRP
 9000   FORMAT(' ERROR ',I4,' IN ')
C
        CALL S88FMT(2,I1MACH(6),FMT(12))
        WRITE(IWUNIT,FMT) CCPLUS,(MESSGP(I),I=1,NWP)
C
 30   RETURN
C
      END
*ECVF
      SUBROUTINE ECVF(NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS AN ERROR MESSAGE WHEN THE LAG VALUE OF
C     THE LAST COVARIANCE COMPUTED BEFORE ONE WAS NOT COMPUTED
C     DUE TO MISSING DATA DOES NOT EXCEED ZERO.
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  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      LOGICAL
     +   HEAD
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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 IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C
      CALL IPRINT(IPRT)
C
      HEAD = .TRUE.
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE(IPRT, 1010)
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT (/
     +   46H THE COVARIANCES AT LAGS ZERO AND/OR ONE COULD,
     +   16H NOT BE COMPUTED/
     +   49H BECAUSE OF MISSING DATA.  NO FURTHER ANALYSIS IS,
     +   10H POSSIBLE.)
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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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
      IF (.NOT.HEAD) RETURN
C
      CALL IPRINT(IPRT)
C
      CALL VERSP(.FALSE.)
      WRITE(IPRT,1010)
      WRITE (IPRT, 1000) (NMSUB(I), I=1,6)
      HEAD = .FALSE.
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/31H ERROR CHECKING FOR SUBROUTINE , 6A1/ 1X, 37('-'))
 1010 FORMAT ('+', 18(1H*)/19H * ERROR MESSAGES */1X, 18(1H*))
C
      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
      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
*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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      IF (MSGTYP.LE.2)
     +   WRITE (IPRT, 1000) (NMVAR(I),I=1,6), YMMN, NV
      IF (MSGTYP.GE.3)
     +   WRITE (IPRT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV
C
      GO TO (10, 20, 30, 40), MSGTYP
C
   10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6), YMMN
      RETURN
C
   20 WRITE(IPRT, 1020) (NMVAR(I),I=1,6), YMMN, NVMX
      RETURN
C
   30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      RETURN
C
   40 WRITE(IPRT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NVMX
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/
     +   31H THE NUMBER OF VALUES IN ARRAY , 6A1,
     +   ' LESS THAN ', I5, 4H IS , I6, '.')
 1005 FORMAT (/
     +   31H THE NUMBER OF VALUES IN ARRAY , 6A1,
     +   ' LESS THAN ', 8A1, 4H IS , I6, '.')
 1010 FORMAT(
     +   25H THE VALUES IN THE ARRAY , 6A1,
     +   ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.')
 1020 FORMAT(
     +   35H THE NUMBER OF VALUES IN THE ARRAY , 6A1,
     +   ' LESS THAN ', 8A1/
     +   19H MUST BE LESS THAN , I5, '.')
 1030 FORMAT(
     +   25H THE VALUES IN THE ARRAY , 6A1,
     +   ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.')
 1040 FORMAT(
     +   35H THE NUMBER OF VALUES IN THE ARRAY , 6A1,
     +   ' LESS THAN ', 8A1/
     +   19H MUST BE LESS THAN , I5, '.')
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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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
      ERROR = .FALSE.
C
      IF (NVAL .EQ. NEQ) RETURN
C
      ERROR = .TRUE.
C
      CALL IPRINT (IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR1(I), I=1,6), NVAL
C
C     PRINT MESSAGE FOR ARIMA ROUTINES
C
      WRITE (IPRT, 1010) (NMVAR1(I), I=1,6), NEQ
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I5, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   ' MUST BE GREATER THAN OR EQUAL TO'/
     +   1X, I5, ' = ONE PLUS THE SUM OF MSPEC(1,J)+MSPEC(3,J) FOR',
     +   ' J = 1, ..., NFAC,'/
     +   6X, ' = ONE PLUS THE NUMBER OF AUTOREGRESSIVE PARAMETERS PLUS'/
     +   9X, ' THE NUMBER OF MOVING AVERAGE PARAMETERS.')
C
      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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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
      ERROR = .FALSE.
C
      IF (NVAL .GE. NMIN) RETURN
C
      ERROR = .TRUE.
C
      CALL IPRINT (IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR1(I), I=1,6), NVAL
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 (IPRT, 1010) (NMVAR1(I), I=1,6), NMIN
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL BASED ON OTHER INPUT
C     ARGUMENTS.
C
   30 WRITE (IPRT, 1020) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8)
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     FIRST DIMENSION OF A DIMENSIONED ARRAY.
C
   40 WRITE (IPRT, 1030) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6),
     +   (NMVAR2(I), I=1,8)
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     SECOND DIMENSION OF A DIMENSIONED ARRAY.
C
   50 WRITE (IPRT, 1040) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6),
     +   (NMVAR2(I), I=1,8)
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHEN ARGUMENT IS LDSTAK.
C
   60 WRITE(IPRT, 1050) NMIN
      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 (IPRT, 1060) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6)
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     DIMENSION OF A VECTOR.
C
   80 WRITE (IPRT, 1070) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6),
     +   (NMVAR2(I), I=1,8)
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     DIMENSION OF THE VECTORS ACOV AND NLPPA.
C
   90 WRITE (IPRT, 1080) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8)
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     DIMENSION OF A VECTOR.
C
  100 WRITE (IPRT, 1090) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6),
     +   NMIN
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I5, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   34H MUST BE GREATER THAN OR EQUAL TO , I5, '.')
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   34H MUST BE GREATER THAN OR EQUAL TO , 8A1, '.')
 1030 FORMAT(
     +   24H THE FIRST DIMENSION OF , 6A1,
     +   30H, AS INDICATED BY THE ARGUMENT/
     +    1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.')
 1040 FORMAT(
     +   25H THE SECOND DIMENSION OF , 6A1,
     +   30H, AS INDICATED BY THE ARGUMENT/
     +    1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.')
 1050 FORMAT(
     +   55H THE DIMENSION OF THE DOUBLE PRECISION VECTOR DSTAK, AS,
     +   13H INDICATED BY/
     +   54H THE ARGUMENT LDSTAK, MUST BE GREATER THAN OR EQUAL TO,
     +   I5, '.')
 1060 FORMAT(
     +   24H THE FIRST DIMENSION OF , 6A1,
     +   30H, AS INDICATED BY THE ARGUMENT/
     +    1X, 6A1, 34H, MUST BE GREATER THAN OR EQUAL TO,
     +   34H THE NUMBER OF UNFIXED PARAMETERS.)
 1070 FORMAT(
     +   15H THE LENGTH OF , 6A1,
     +   30H, AS INDICATED BY THE ARGUMENT/
     +    1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.')
 1080 FORMAT(
     +   29H THE LENGTH OF ACOV AND NLPPA,
     +   30H, AS INDICATED BY THE ARGUMENT/
     +    1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.')
 1090 FORMAT(
     +   15H THE LENGTH OF , 6A1,
     +   30H, AS INDICATED BY THE ARGUMENT/
     +    1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , I6, '.')
C
      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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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
      ERROR = .FALSE.
C
      IF (((IVALMN.LE.IVAL) .AND. (IVAL.LE.IVALMX)) .OR.
     +   (IVALMX.LT.IVALMN)) RETURN
C
      ERROR = .TRUE.
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      IF (MSGTYP.LE.2) WRITE (IPRT, 1000) (NMVAR(I),I=1,6), IVAL
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM
C     OTHER INPUT ARGUMENTS.
C
      IF (MSGTYP .EQ. 1)
     +   WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +      (NMMAX(I),I=1,8)
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC
C
      IF (MSGTYP .EQ. 2)
     +   WRITE (IPRT, 1020) (NMVAR(I),I=1,6), IVALMN, IVALMX
C
C     PRINT MESSAGE FOR AOV ROUTINES
C
      IF (MSGTYP .EQ. 3)
     +   WRITE (IPRT, 1030)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I6, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   16H MUST BE BETWEEN, 1X, 8A1,
     +   5H AND , 8A1, 12H, INCLUSIVE.)
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   16H MUST BE BETWEEN, 1X, I6,
     +   5H AND , I6, 12H, INCLUSIVE.)
 1030 FORMAT(/' THE NUMBER OF DISTINCT GROUPS (NG) MUST BE BETWEEN'/
     +  ' TWO AND ONE LESS THAN THE NUMBER OF POSITIVE TAG VALUES.')
C
      END
*EISLE
      SUBROUTINE EISLE(NMSUB, NMVAR1, NVAL, NMAX, MSGTYP, HEAD, ERROR,
     +   NMVAR2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER THE VALUE   NVAL   IS LESS THAN
C     OR EQUAL TO   NMAX   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  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   MSGTYP,NMAX,NVAL
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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 IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER NMAX
C        THE MAXIMUM ACCEPTABLE VALUE FOR THE ARGUMENT BEING TESTED.
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 LARGE BASED
C                   ON LIMITS IMPOSED BY STARPAC
C        MSGTYP = 2 THE INPUT VALUE WAS TOO LARGE BASED ON OTHER INPUT
C                   ARGUMENTS.
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
      ERROR = .FALSE.
C
      IF (NVAL .LE. NMAX) RETURN
C
      ERROR = .TRUE.
C
      CALL IPRINT (IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR1(I), I=1,6), NVAL
C
      GO TO (10, 20), MSGTYP
C
C     PRINT MESSAGE FOR VALUE TOO LARGE BASED ON LIMITS IMPOSED
C     BY STARPAC.
C
   10 WRITE (IPRT, 1010) (NMVAR1(I), I=1,6), NMAX
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO LARGE BASED ON OTHER INPUT
C     ARGUMENTS.
C
   20 WRITE (IPRT, 1020) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I5, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   31H MUST BE LESS THAN OR EQUAL TO , I5, '.')
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   31H MUST BE LESS THAN OR EQUAL TO , 8A1, '.')
C
      END
*EISRNG
      SUBROUTINE EISRNG (NMSUB, ISEED, ISEEDU, HEAD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER THE INPUT VARIABLE ISEED IS
C     WITHIN [0, 2**MDIG], AND, IF NONZERO, IS ODD.
C
C     IF ISEED IS WITHIN [0, 2**MDIG] THEN
C        ISEEDU = ISEED-MOD(ISEED,2)+1
C     ELSE
C        ISEEDU = MIN[ ABS(ISEED)-MOD(ABS(ISEED),2)+1, 2**(MDIG-1)-1]
C                 AND AN ERROR MESSAGE IS PRINTED.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    CENTER FOR COMPUTING AND APPLIED MATHEMATICS
C                    NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                    BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 17, 1990
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISEED,ISEEDU
      LOGICAL
     +   HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,MDIG
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   I1MACH
      EXTERNAL I1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MIN,MOD
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 IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISEED
C        THE VALUE OF THE SEED BEING TESTED.
C     INTEGER ISEEDU
C        THE VALUE OF THE SEED ACTUALLY USED BY NRAND AND NRANDC.
C     INTEGER MDIG
C        A LOWER BOUND ON THE NUMBER OF BINARY DIGITS AVAILABLE
C        FOR REPRESENTING INTEGERS, INCLUDING THE SIGN BIT.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C
      MDIG = MIN(I1MACH(8)+1,32)
C
C     CHECK FOR VIOLATIONS
C
      IF ((ISEED.EQ.0) .OR.
     +    ((ISEED.GE.1) .AND.
     +     (ISEED.LE.2**(MDIG-1)-1) .AND.
     +     (MOD(ISEED,2).EQ.1))) THEN
C
C     SUPPLIED SEED WILL BE USED
C
         ISEEDU = ISEED
      ELSE
C
C     VIOLATIONS FOUND
C
         ISEEDU = MIN( ABS(ISEED)+MOD(ABS(ISEED),2)-1, 2**(MDIG-1)-1)
         CALL IPRINT(IPRT)
         CALL EHDR(NMSUB, HEAD)
         WRITE (IPRT, 1010) MDIG-1,ISEEDU
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(/
     +   ' THE VALUE OF ISEED MUST BE BETWEEN 0 AND 2**',I2,' - 1,'/
     +   ' INCLUSIVE, AND, IF ISEED IS NOT 0, ISEED MUST BE ODD.  THE'/
     +   ' SEED ACTUALLY USED BY THE RANDOM NUMBER GENERATOR HAS BEEN'/
     +   ' SET TO', I10,'.')
C
      END
*EIVEO
      SUBROUTINE EIVEO (NMSUB, NMVAR, IVEC, N, EVEN, HEAD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER EACH OF THE VALUES IN THE INPUT
C     VECTOR IVEC ARE EVEN (OR ODD) AND PRINTS A
C     DIAGNOSTIC IF THEY ARE NOT.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   N
      LOGICAL
     +   EVEN,HEAD
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IVEC(*)
      CHARACTER
     +   NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL EVEN
C        AN INDICATOR VARIABLE DESIGNATING WHETHER THE VALUES OF IVEC
C        SHOULD BE EVEN (TRUE) OR NOT (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 IVEC(N)
C        THE VECTOR BEING TESTED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE PARAMETERS NAME.
C
C     CHECK FOR VIOLATIONS
C
      DO 10 I = 1, N
         IF ((EVEN .AND. (MOD(IVEC(I), 2) .EQ. 1)) .OR.
     +       ((.NOT.EVEN) .AND. (MOD(IVEC(I), 2) .EQ. 1))) GO TO 20
   10 CONTINUE
C
      RETURN
C
C     VIOLATIONS FOUND
C
   20 CONTINUE
C
      CALL IPRINT(IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      IF (EVEN) GO TO 40
C
      WRITE (IPRT, 1010) (NMVAR(I), I = 1, 6)
      RETURN
C
   40 CONTINUE
      WRITE (IPRT, 1020) (NMVAR(I), I = 1, 6)
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(/
     +   26H THE VALUES IN THE VECTOR , 6A1,
     +   27H MUST ALL BE ODD.  THE NEXT/
     +   53H LARGER INTEGER WILL BE USED IN PLACE OF EVEN VALUES.)
 1020 FORMAT(/
     +   26H THE VALUES IN THE VECTOR , 6A1,
     +   28H MUST ALL BE EVEN.  THE NEXT/
     +   52H LARGER INTEGER WILL BE USED IN PLACE OF ODD VALUES.)
C
      END
*EIVEQ
      SUBROUTINE EIVEQ (NMSUB, NMVAR1, IVEC, N, IVAL, NEQMN, HEAD, NEQ,
     +                  NNE, MSGTYP, ERROR, NMVAR2, NMVAR3)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER THE NUMBER OF ELEMENTS OF IVEC EQUAL
C     TO IVAL IS AT LEAST NEQMN.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  AUGUST 3, 1987
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IVAL,MSGTYP,N,NEQ,NEQMN,NNE
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IVEC(*)
      CHARACTER
     +   NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1,NMVAR3(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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 IVEC(N)
C        THE VECTOR BEING CHECKED.
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 ON LIMITS
C                    IMPOSED BY STARPAC.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
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     CHARACTER*1 NMVAR3(8)
C        THE CHARACTERS OF THE NAME OF THE ARGUMENT THAT THE ELEMENTS
C        MUST BE EQUAL TO.
C     INTEGER NEQ
C        THE NUMBER OF ELEMENTS EQUAL TO IVAL.
C     INTEGER NEQMN
C        THE MINIMUM NUMBER OF ELEMENTS EQUAL TO IVAL WHICH IS OK.
C     INTEGER NNE
C        THE NUMBER OF ELEMENTS NOT EQUAL TO IVAL.
C
      ERROR = .FALSE.
C
      IF (N.LE.0) RETURN
C
C     CHECK FOR VALUES EQUAL TO IVAL
C
      NEQ = 0
      DO 10 I = 1, N
         IF (IVEC(I) .EQ. IVAL) NEQ = NEQ + 1
   10 CONTINUE
C
      NNE = N - NEQ
      IF (NEQ .GE. NEQMN) RETURN
C
C     INSUFFICIENT NUMBER OF ELEMENTS EQUAL TO IVAL.
C
      ERROR = .TRUE.
C
      CALL IPRINT(IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      IF (MSGTYP.EQ.1) WRITE(IPRT, 1000)
     +   (NMVAR1(I),I=1,8), (NMVAR2(I),I=1,8), NEQ,
     +   (NMVAR2(I),I=1,8), (NMVAR3(I),I=1,8)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(
     +   ' THE NUMBER OF ELEMENTS IN ', 8A1,
     +   ' EQUAL TO ', 8A1, ' IS ', I6, '.'/
     +   ' THE NUMBER OF ELEMENTS EQUAL TO ', 8A1,
     +   ' MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.')
C
      END
*EIVII
      SUBROUTINE EIVII (NMSUB, NMVAR, IVEC, N, IVECLB, IVECUB, NVMX,
     +   HEAD, MSGTYP, NV, ERROR, NMMIN, NMMAX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS FOR VALUES IN THE INPUT VECTOR IVEC
C     WHICH ARE OUTSIDE THE (INCLUSIVE) LIMITS IVECLB TO IVECUB, PRINTS
C     AN ERROR MESSAGE IF THE NUMBER OF VIOLATIONS EXCEEDS THE LARGEST
C     NUMBER OF VIOLATIONS ALLOWED, AND RETURNS THE NUMBER OF
C     VIOLATIONS AND AN ERROR FLAG INDICATING THE RESULTS.
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
     +   IVECLB,IVECUB,MSGTYP,N,NV,NVMX
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IVEC(*)
      CHARACTER
     +   NMMAX(8)*1,NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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 IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVEC(N)
C        THE VECTOR BEING TESTED.
C     INTEGER IVECLB, IVECUB
C        THE (INCLUSIVE) RANGE THAT THE VECTOR IS BEING TESTED
C        AGAINST.
C     INTEGER MSGTYP
C        THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE.
C        IF (MSGTYP.GE.4) THE MESSAGE PRINTED WILL USE NMMIN AND
C        NMMAX, OTHERWISE IT WILL USE IVECLB AND IVECUB.
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 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     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND.
C     INTEGER NVMX
C        THE LARGEST NUMBER OF VIOLATIONS ALLOWED.
C
      ERROR = .FALSE.
C
      IF (N.LE.0) RETURN
      IF (IVECUB.LT.IVECLB) RETURN
C
C     TEST WHETHER TESTING IS NECESSRY
C
      IF ((MOD(MSGTYP,3) .EQ. 0) .AND.
     +    ((IVEC(1) .LT. IVECLB) .OR. (IVEC(1) .GT. IVECUB))) RETURN
C
C     CHECK FOR VIOLATIONS
C
      NV = 0
      DO 5 I = 1, N
         IF ((IVEC(I).LT.IVECLB) .OR. (IVEC(I).GT.IVECUB)) NV = NV + 1
    5 CONTINUE
C
      IF (NV .LE. NVMX) RETURN
C
C     VIOLATIONS FOUND
C
      ERROR = .TRUE.
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      IF (MSGTYP.LE.3)
     +   WRITE (IPRT, 1000) (NMVAR(I),I=1,6), IVECLB, IVECUB, NV
      IF (MSGTYP.GE.4)
     +   WRITE (IPRT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +   (NMMAX(I),I=1,8), NV
C
      GO TO (10, 20, 30, 10, 20, 30), MSGTYP
C
   10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6)
      RETURN
C
   20 WRITE(IPRT, 1020) (NMVAR(I),I=1,6), NVMX
      RETURN
C
   30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/
     +   32H THE NUMBER OF VALUES IN VECTOR , 6A1,
     +   19H OUTSIDE THE RANGE , I6, 3H TO/
     +   1X, I6, 16H, INCLUSIVE, IS , I6, '.')
 1005 FORMAT (/
     +   32H THE NUMBER OF VALUES IN VECTOR , 6A1,
     +   19H OUTSIDE THE RANGE , 8A1, 3H TO/
     +   1X, 8A1, 16H, INCLUSIVE, IS , I6, '.')
 1010 FORMAT(
     +   26H THE VALUES IN THE VECTOR , 6A1,
     +   31H MUST ALL BE WITHIN THIS RANGE.)
 1020 FORMAT(
     +   36H THE NUMBER OF VALUES IN THE VECTOR , 6A1,
     +   19H OUTSIDE THIS RANGE/
     +   19H MUST BE LESS THAN , I5, '.')
 1030 FORMAT(
     +   34H IF THE FIRST VALUE OF THE VECTOR , 6A1,
     +   21H IS WITHIN THIS RANGE/
     +   45H ALL OF THE VALUES MUST BE WITHIN THIS RANGE.)
C
      END
*ENFFT
      SUBROUTINE ENFFT(NMSUB, NFFT, NDIV, N, LYFFT, NFFT2, HEAD, ERROR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER THE VALUE NFFT IS SUCH THAT NFFT-2 IS
C     DIVISIBLE BY NDIV AND HAS NO PRIME FACTORS GREATER THAN 23, AND
C     THE PRODUCT OF THE SQUARE FREE PRIME FACTORS OF NFFT - 2 DO NOT
C     EXCEED 209, I.E., THE VALUE OF NFFT MEETS THE REQUIREMENTS OF
C     THE EXTENDED LENGTH OF THE SERIES REQUIRED FOR ANY ROUTINE
C     USING THE SINGLETON FFT PROVIDING THE PROPER VALUE OF NDIV
C     IS CHOSEN.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LYFFT,N,NDIV,NFFT,NFFT2
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,NFFT1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT,SETESL
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
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 IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR CONTAINING THE SERIES TO BE EXTENDED.
C     INTEGER N
C        THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     INTEGER NFFT
C        THE USER SUPPLIED EXTENDED SERIES LENGTH.
C     INTEGER NFFT1
C        THE MAXIMUM OF NFFT AND N+2.
C     INTEGER NFFT2
C        THE SMALLEST EXTENDED SERIES LENGTH WHICH EQUALS OR
C        EXCEEDS NFFT AND WHICH MEETS THE REQUIREMENTS OF
C        SINGLETONS FFT CODE.
C
      ERROR = .FALSE.
      CALL IPRINT (IPRT)
C
      IF (NFFT .GE. N+2) GO TO 20
C
C     PRINT WARNING
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1050) N
C
   20 CONTINUE
      NFFT1 = MAX(NFFT, N+2)
      CALL SETESL(NFFT1-2, NDIV, NFFT2)
C
      IF (NFFT .EQ. NFFT2) RETURN
C
C     PRINT WARNING
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1020) NFFT, NFFT2
C
      IF (NFFT .GT. LYFFT) GO TO 40
C
      WRITE (IPRT, 1030) NFFT2
      RETURN
C
   40 CONTINUE
C
      ERROR = .TRUE.
C
      WRITE (IPRT, 1040) NFFT2, LYFFT
      RETURN
C
C     FORMAT STATEMENTS
C
 1020 FORMAT (/
     +   40H THE INPUT VALUE OF THE PARAMETER NFFT (, I5,
     +   15H) DOES NOT MEET/
     +   51H THE REQUIREMENTS OF SINGLETONS FFT CODE.  THE NEXT,
     +   13H LARGER VALUE/
     +   15H WHICH DOES IS , I5, '.')
 1030 FORMAT (/
     +   11H THE VALUE , I5, 37H WILL BE USED FOR THE EXTENDED SERIES,
     +    8H LENGTH.)
 1040 FORMAT (/
     +   20H HOWEVER, THE VALUE , I5, 27H EXCEEDS THE LENGTH LYFFT (,
     +   I5, 8H) OF THE/
     +   58H VECTOR YFFT, AND THEREFORE CANNOT BE USED AS THE EXTENDED/
     +   43H SERIES LENGTH WITHOUT REDIMENSIONING YFFT.)
 1050 FORMAT (/
     +   56H THE EXTENDED SERIES LENGTH (NFFT) MUST EQUAL OR EXCEED,/
     +   45H THE NUMBER OF OBSERVATIONS IN THE SERIES (N=, I5,
     +    9H) PLUS 2.)
C
      END
*EPRINT
      SUBROUTINE EPRINT
C
C  THIS SUBROUTINE PRINTS THE LAST ERROR MESSAGE, IF ANY.
C
C
C  VARIABLE DECLARATIONS
C
C  LOCAL ARRAYS
      CHARACTER MESSG(1)*4
C
C  EXTERNAL SUBROUTINES
      EXTERNAL E9RINT
C
C
      CALL E9RINT(MESSG,1,1,.FALSE.)
      RETURN
C
      END
*ERAGT
      SUBROUTINE ERAGT (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
      REAL
     +   YMMN
      INTEGER
     +   IYM,M,MSGTYP,N,NV,NVMX
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ERAGTP
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     REAL YM(IYM,M)
C        THE ARRAY BEING TESTED.
C     REAL YMMN
C        THE MINIMUM ACCEPTABLE VALUE.
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) .LE. YMMN) NV = NV + 1
    1    CONTINUE
    5 CONTINUE
C
      IF (NV .LE. NVMX) RETURN
C
C     VIOLATIONS FOUND
C
      ERROR = .TRUE.
C
      CALL ERAGTP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV,
     +   NMMIN)
C
      RETURN
C
      END
*ERAGTM
      SUBROUTINE ERAGTM (NMSUB, NMVAR, YM, YMMISS, 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     ELEMENTS OF YM(*, I) EQUAL TO YMMISS(I) ARE EXEMPT FROM CHECKING.
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
      REAL
     +   YMMN
      INTEGER
     +   IYM,M,MSGTYP,N,NV,NVMX
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      EXTERNAL MVCHK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ERAGTP
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     REAL YM(IYM,M)
C        THE ARRAY BEING TESTED.
C     REAL YMMISS(M)
C        MISSING VALUE CODES FOR EACH COLUMN OF YM
C     REAL YMMN
C        THE MINIMUM ACCEPTABLE VALUE.
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 (MVCHK(YM(I+(J-1)*IYM), YMMISS(J))) GO TO 1
            IF (YM(I+(J-1)*IYM) .LE. YMMN) NV = NV + 1
    1    CONTINUE
    5 CONTINUE
C
      IF (NV .LE. NVMX) RETURN
C
C     VIOLATIONS FOUND
C
      ERROR = .TRUE.
      CALL ERAGTP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV,
     +   NMMIN)
C
      RETURN
C
      END
*ERAGTP
      SUBROUTINE ERAGTP (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
      REAL
     +   YMMN
      INTEGER
     +   MSGTYP,NV,NVMX
      LOGICAL
     +   HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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     REAL YMMN
C        THE MINIMUM ACCEPTABLE VALUE.
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      IF (MSGTYP.LE.2)
     +   WRITE (IPRT, 1000) (NMVAR(I),I=1,6), YMMN, NV
      IF (MSGTYP.GE.3)
     +   WRITE (IPRT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV
C
      GO TO (10, 20, 30, 40), MSGTYP
C
   10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6), YMMN
      RETURN
C
   20 WRITE(IPRT, 1020) (NMVAR(I),I=1,6), YMMN, NVMX
      RETURN
C
   30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      RETURN
C
   40 WRITE(IPRT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NVMX
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/
     +   31H THE NUMBER OF VALUES IN ARRAY , 6A1,
     +   23H LESS THAN OR EQUAL TO , 1PE14.7, 4H IS , I6, '.')
 1005 FORMAT (/
     +   31H THE NUMBER OF VALUES IN ARRAY , 6A1,
     +   23H LESS THAN OR EQUAL TO , 8A1, 4H IS , I6, '.')
 1010 FORMAT(
     +   25H THE VALUES IN THE ARRAY , 6A1,
     +   26H MUST ALL BE GREATER THAN , 1PE14.7, '.')
 1020 FORMAT(
     +   35H THE NUMBER OF VALUES IN THE ARRAY , 6A1,
     +   23H LESS THAN OR EQUAL TO , 8A1/
     +   19H MUST BE LESS THAN , I5, '.')
 1030 FORMAT(
     +   25H THE VALUES IN THE ARRAY , 6A1,
     +   26H MUST ALL BE GREATER THAN , 1PE14.7, '.')
 1040 FORMAT(
     +   35H THE NUMBER OF VALUES IN THE ARRAY , 6A1,
     +   23H LESS THAN OR EQUAL TO , 8A1/
     +   19H MUST BE LESS THAN , I5, '.')
C
      END
*ERDF
      SUBROUTINE ERDF(NMSUB, NDF, IOD, ND, N, 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 DIFFERENCING ON A 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 21, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NDF
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IOD(*),ND(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IER,IPRT,MBOD
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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 IER
C        AN ERROR INDICATOR.
C     INTEGER IOD(NDF)
C        THE VECTOR CONTAINING THE ORDERS OF EACH DIFFERENCE FACTOR.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MBOD
C        THE MAXIMUM BACKORDER DUE TO DIFFERENCING.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER ND(NDF)
C        THE VECTOR CONTAINING THE NUMBER OF TIMES EACH DIFFERENCE
C        FACTOR IS APPLIED.
C     INTEGER NDF
C        THE NUMBER OF DIFFERENCE FACTORS TO BE APPLIED TO THE SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINE NAME.
C
      ERROR = .FALSE.
C
      IF (NDF .GE. 0) GO TO 10
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE (IPRT, 1001) NDF
      ERROR = .TRUE.
      RETURN
C
   10 IF (NDF .EQ. 0) RETURN
C
      IER = 0
      MBOD = 0
      DO 30 I = 1, NDF
         IF (IOD(I) .GE. 1 .AND. ND(I) .GE. 1) GO TO 20
         IER = 1
         GO TO 40
   20    MBOD = MBOD + IOD(I) * ND(I)
   30 CONTINUE
      IF (MBOD .LE. N - 1) RETURN
C
   40 CONTINUE
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      IF (IER .EQ. 1)
     +   WRITE (IPRT, 1002) (I, ND(I), IOD(I), I = 1, NDF)
      IF (IER .EQ. 0 .AND. MBOD .GE. N) WRITE (IPRT, 1003) MBOD, N
      ERROR = .TRUE.
      RETURN
C
C     FORMAT STATEMENTS
C
 1001 FORMAT(/44H THE NUMBER OF DIFFERENCE FACTORS (NDF) MUST/
     +   54H BE GREATER THAN OR EQUAL TO ZERO.  THE INPUT VALUE OF/
     +   8H NDF IS , I6, '.')
 1002 FORMAT (/46H THE ORDER OF EACH DIFFERENCE FACTOR (IOD) AND/
     +   56H NUMBER OF TIMES IT IS APPLIED (ND) MUST BE GREATER THAN/
     +   52H EQUAL TO ONE.  THE INPUT VALUES OF THESE ARRAYS ARE/
     +   25H    DIF. FACT.   ND   IOD/
     +   (1X, I13, I5, I6))
 1003 FORMAT (/50H THE MAXIMUM BACKORDER DUE TO DIFFERENCING (MBOD),
     +  /54H THAT IS, THE SUM OF ND(I)*IOD(I), I = 1, 2, ..., NDF,/
     +   59H MUST BE LESS THAN OR EQUAL TO N-1.  THE COMPUTED VALUE FOR/
     +   9H MBOD IS , I6, 33H, WHILE THE INPUT VALUE FOR N IS , I6, '.')
      END
*ERFC
      REAL FUNCTION ERFC (X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
C
C  LOCAL SCALARS
      REAL ETA,SQEPS,SQRTPI,XMAX,XSML,Y
      INTEGER NTERC2,NTERF,NTERFC
C
C  LOCAL ARRAYS
      REAL ERC2CS(23),ERFCCS(24),ERFCS(13)
C
C  EXTERNAL FUNCTIONS
      REAL CSEVL,R1MACH
      INTEGER INITS
      EXTERNAL CSEVL,R1MACH,INITS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,EXP,LOG,SQRT
C
C
C SERIES FOR ERF        ON THE INTERVAL  0.          TO  1.00000D+00
C                                        WITH WEIGHTED ERROR   7.10E-18
C                                         LOG WEIGHTED ERROR  17.15
C                               SIGNIFICANT FIGURES REQUIRED  16.31
C                                    DECIMAL PLACES REQUIRED  17.71
C
      DATA ERF CS( 1) /   -.0490461212 34691808E0 /
      DATA ERF CS( 2) /   -.1422612051 0371364E0 /
      DATA ERF CS( 3) /    .0100355821 87599796E0 /
      DATA ERF CS( 4) /   -.0005768764 69976748E0 /
      DATA ERF CS( 5) /    .0000274199 31252196E0 /
      DATA ERF CS( 6) /   -.0000011043 17550734E0 /
      DATA ERF CS( 7) /    .0000000384 88755420E0 /
      DATA ERF CS( 8) /   -.0000000011 80858253E0 /
      DATA ERF CS( 9) /    .0000000000 32334215E0 /
      DATA ERF CS(10) /   -.0000000000 00799101E0 /
      DATA ERF CS(11) /    .0000000000 00017990E0 /
      DATA ERF CS(12) /   -.0000000000 00000371E0 /
      DATA ERF CS(13) /    .0000000000 00000007E0 /
C
C SERIES FOR ERFC       ON THE INTERVAL  0.          TO  2.50000D-01
C                                        WITH WEIGHTED ERROR   4.81E-17
C                                         LOG WEIGHTED ERROR  16.32
C                        APPROX SIGNIFICANT FIGURES REQUIRED  15.0
C SERIES FOR ERC2       ON THE INTERVAL  2.50000D-01 TO  1.00000D+00
C                                        WITH WEIGHTED ERROR   5.22E-17
C                                         LOG WEIGHTED ERROR  16.28
C                        APPROX SIGNIFICANT FIGURES REQUIRED  15.0
C                                    DECIMAL PLACES REQUIRED  16.96
C
      DATA ERC2CS( 1) /   -.0696013466 02309501E0 /
      DATA ERC2CS( 2) /   -.0411013393 62620893E0 /
      DATA ERC2CS( 3) /    .0039144958 66689626E0 /
      DATA ERC2CS( 4) /   -.0004906395 65054897E0 /
      DATA ERC2CS( 5) /    .0000715747 90013770E0 /
      DATA ERC2CS( 6) /   -.0000115307 16341312E0 /
      DATA ERC2CS( 7) /    .0000019946 70590201E0 /
      DATA ERC2CS( 8) /   -.0000003642 66647159E0 /
      DATA ERC2CS( 9) /    .0000000694 43726100E0 /
      DATA ERC2CS(10) /   -.0000000137 12209021E0 /
      DATA ERC2CS(11) /    .0000000027 88389661E0 /
      DATA ERC2CS(12) /   -.0000000005 81416472E0 /
      DATA ERC2CS(13) /    .0000000001 23892049E0 /
      DATA ERC2CS(14) /   -.0000000000 26906391E0 /
      DATA ERC2CS(15) /    .0000000000 05942614E0 /
      DATA ERC2CS(16) /   -.0000000000 01332386E0 /
      DATA ERC2CS(17) /    .0000000000 00302804E0 /
      DATA ERC2CS(18) /   -.0000000000 00069666E0 /
      DATA ERC2CS(19) /    .0000000000 00016208E0 /
      DATA ERC2CS(20) /   -.0000000000 00003809E0 /
      DATA ERC2CS(21) /    .0000000000 00000904E0 /
      DATA ERC2CS(22) /   -.0000000000 00000216E0 /
      DATA ERC2CS(23) /    .0000000000 00000052E0 /
C
C                                    DECIMAL PLACES REQUIRED  17.01
C
      DATA ERFCCS( 1) /   0.0715179310 202925E0 /
      DATA ERFCCS( 2) /   -.0265324343 37606719E0 /
      DATA ERFCCS( 3) /    .0017111539 77920853E0 /
      DATA ERFCCS( 4) /   -.0001637516 63458512E0 /
      DATA ERFCCS( 5) /    .0000198712 93500549E0 /
      DATA ERFCCS( 6) /   -.0000028437 12412769E0 /
      DATA ERFCCS( 7) /    .0000004606 16130901E0 /
      DATA ERFCCS( 8) /   -.0000000822 77530261E0 /
      DATA ERFCCS( 9) /    .0000000159 21418724E0 /
      DATA ERFCCS(10) /   -.0000000032 95071356E0 /
      DATA ERFCCS(11) /    .0000000007 22343973E0 /
      DATA ERFCCS(12) /   -.0000000001 66485584E0 /
      DATA ERFCCS(13) /    .0000000000 40103931E0 /
      DATA ERFCCS(14) /   -.0000000000 10048164E0 /
      DATA ERFCCS(15) /    .0000000000 02608272E0 /
      DATA ERFCCS(16) /   -.0000000000 00699105E0 /
      DATA ERFCCS(17) /    .0000000000 00192946E0 /
      DATA ERFCCS(18) /   -.0000000000 00054704E0 /
      DATA ERFCCS(19) /    .0000000000 00015901E0 /
      DATA ERFCCS(20) /   -.0000000000 00004729E0 /
      DATA ERFCCS(21) /    .0000000000 00001432E0 /
      DATA ERFCCS(22) /   -.0000000000 00000439E0 /
      DATA ERFCCS(23) /    .0000000000 00000138E0 /
      DATA ERFCCS(24) /   -.0000000000 00000048E0 /
C
      DATA SQRTPI /1.772453850 9055160E0/
      DATA NTERF, NTERFC, NTERC2, XSML, XMAX, SQEPS /3*0, 3*0./
C
      IF (NTERF.NE.0) GO TO 10
      ETA = 0.1*R1MACH(3)
      NTERF = INITS (ERFCS, 13, ETA)
      NTERFC = INITS (ERFCCS, 24, ETA)
      NTERC2 = INITS (ERC2CS, 23, ETA)
C
      XSML = -SQRT (-LOG(SQRTPI*R1MACH(3)))
      XMAX = SQRT (-LOG(SQRTPI*R1MACH(1)))
      XMAX = XMAX - 0.5*LOG(XMAX)/XMAX - 0.01
      SQEPS = SQRT (2.0*R1MACH(3))
C
 10   IF (X.GT.XSML) GO TO 20
C
C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML
C
      ERFC = 2.0
      RETURN
C
 20   IF (X.GT.XMAX) GO TO 40
      Y = ABS(X)
      IF (Y.GT.1.0) GO TO 30
C
C ERFC(X) = 1.0 - ERF(X) FOR -1. .LE. X .LE. 1.
C
      IF (Y.LT.SQEPS) THEN
         ERFC = 1.0 - 2.0*X/SQRTPI
      ELSE
         ERFC = 1.0 - X*(1.0 + CSEVL (2.*X*X-1., ERFCS, NTERF) )
      END IF
C
      RETURN
C
C ERFC(X) = 1.0 - ERF(X) FOR 1. .LT. ABS(X) .LE. XMAX
C
 30   Y = Y*Y
      IF (Y.LE.4.) THEN
         ERFC = EXP(-Y)/ABS(X) *
     +         (0.5 + CSEVL ((8.0/Y-5.0)/3.0, ERC2CS, NTERC2) )
      ELSE
         ERFC = EXP(-Y)/ABS(X) *
     +          (0.5 + CSEVL (8.0/Y-1.0, ERFCCS, NTERFC) )
      END IF
      IF (X.LT.0.0) ERFC = 2.0 - ERFC
      RETURN
C
 40   CALL XERROR ('ERFC    X SO BIG ERFC UNDERFLOWS', 32, 1, 1)
      ERFC = 0.0
      RETURN
C
      END
*ERF
      REAL FUNCTION ERF (X)
C APRIL 1977 VERSION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
C
C  LOCAL SCALARS
      REAL SQEPS,SQRTPI,XBIG,Y
      INTEGER NTERF
C
C  LOCAL ARRAYS
      REAL ERFCS(13)
C
C  EXTERNAL FUNCTIONS
      REAL CSEVL,ERFC,R1MACH
      INTEGER INITS
      EXTERNAL CSEVL,ERFC,R1MACH,INITS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG,SIGN,SQRT
C
C
C SERIES FOR ERF        ON THE INTERVAL  0.          TO  1.00000D+00
C                                        WITH WEIGHTED ERROR   7.10E-18
C                                         LOG WEIGHTED ERROR  17.15
C                               SIGNIFICANT FIGURES REQUIRED  16.31
C                                    DECIMAL PLACES REQUIRED  17.71
C
      DATA ERF CS( 1) /   -.0490461212 34691808E0 /
      DATA ERF CS( 2) /   -.1422612051 0371364E0 /
      DATA ERF CS( 3) /    .0100355821 87599796E0 /
      DATA ERF CS( 4) /   -.0005768764 69976748E0 /
      DATA ERF CS( 5) /    .0000274199 31252196E0 /
      DATA ERF CS( 6) /   -.0000011043 17550734E0 /
      DATA ERF CS( 7) /    .0000000384 88755420E0 /
      DATA ERF CS( 8) /   -.0000000011 80858253E0 /
      DATA ERF CS( 9) /    .0000000000 32334215E0 /
      DATA ERF CS(10) /   -.0000000000 00799101E0 /
      DATA ERF CS(11) /    .0000000000 00017990E0 /
      DATA ERF CS(12) /   -.0000000000 00000371E0 /
      DATA ERF CS(13) /    .0000000000 00000007E0 /
C
      DATA SQRTPI /1.772453850 9055160E0/
      DATA NTERF, XBIG, SQEPS / 0, 0., 0./
C
      IF (NTERF.NE.0) GO TO 10
      NTERF = INITS (ERFCS, 13, 0.1*R1MACH(3))
      XBIG = SQRT(-LOG(SQRTPI*R1MACH(3)))
      SQEPS = SQRT(2.0*R1MACH(3))
C
 10   Y = ABS(X)
      IF (Y.GT.1.) GO TO 20
C
C ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1.
C
      IF (Y.LE.SQEPS) THEN
         ERF = 2.0*X/SQRTPI
      ELSE
         ERF = X*(1.0 + CSEVL(2.*X**2-1., ERFCS, NTERF))
      END IF
C
      RETURN
C
C ERF(X) = 1. - ERFC(X) FOR  ABS(X) .GT. 1.
C
 20   IF (Y.LE.XBIG) THEN
         ERF = SIGN (1.0-ERFC(Y), X)
      ELSE
         ERF = SIGN (1.0, X)
      END IF
C
      RETURN
      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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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
      ERROR = .FALSE.
C
      IF (MSGTYP .EQ. 2) GO TO 10
C
C     CHECK FOR ODD
C
      IF (MOD(NVAL, 2) .EQ. 1) RETURN
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE(IPRT, 1010) (NMVAR(I), I = 1, 6), (NMVAR(I), I = 1, 6), NVAL
      ERROR = .TRUE.
      RETURN
C
   10 CONTINUE
C
C     CHECK FOR EVEN
C
      IF (MOD(NVAL, 2) .EQ. 0) RETURN
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE(IPRT, 1020) (NMVAR(I), I = 1, 6), (NMVAR(I), I = 1, 6), NVAL
      ERROR = .TRUE.
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(/
     +   27H THE VALUE OF THE VARIABLE , 6A1,
     +   34H MUST BE ODD.  THE INPUT VALUE OF , 6A1/
     +    4H IS , I5, '.')
 1020 FORMAT(/
     +   27H THE VALUE OF THE VARIABLE , 6A1,
     +   35H MUST BE EVEN.  THE INPUT VALUE OF , 6A1/
     +    4H IS , I5, '.')
C
      END
*ERSEI
      SUBROUTINE ERSEI(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 (EXCLUSIVE) 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
      REAL
     +   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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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     REAL VAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C     REAL VALMN, VALMX
C        THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE
C        ARGUMENT MUST LIE.
C
      ERROR = .FALSE.
C
      IF (((VALMN.LT.VAL) .AND. (VAL.LE.VALMX)) .OR.
     +   (VALMX.LT.VALMN)) RETURN
C
      ERROR = .TRUE.
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM
C     OTHER INPUT ARGUMENTS.
C
      IF (MSGTYP .EQ. 1)
     +   WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +      (NMMAX(I),I=1,8)
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC
C
      IF (MSGTYP .EQ. 2)
     +   WRITE (IPRT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   17H MUST LIE BETWEEN, 1X, 8A1, 12H (EXCLUSIVE)/
     +   5H AND , 8A1, 13H (INCLUSIVE).)
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   17H MUST LIE BETWEEN, 1X, G15.8, 12H (EXCLUSIVE)/
     +   5H AND , G15.8, 13H (INCLUSIVE).)
C
      END
*ERSGE
      SUBROUTINE ERSGE(NMSUB, NMVAR, VAL, VALMN, MSGTYP, HEAD, ERROR,
     +   NMMIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THE ROUTINE CHECKS WHETHER THE VALUE   VAL   IS GREATER THAN OR
C     EQUAL TO   VALMN   , 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  -  JUNE 10, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   VAL,VALMN
      INTEGER
     +   MSGTYP
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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
C                   LIMITS BASED ON OTHER INPUT ARGUMENTS.
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     REAL VAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C     REAL VALMN
C        THE MINIMUM VALUE THE ARGUMENT CAN VALIDLY HAVE.
C
      ERROR = .FALSE.
C
      IF (VAL .GE. VALMN) RETURN
C
      ERROR = .TRUE.
      CALL IPRINT (IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL
C
      GO TO (10, 20), MSGTYP
C
C     PRINT MESSAGE FOR VALUE TOO SMALL BASED ON LIMITS IMPOSED
C     BY STARPAC.
C
   10 WRITE (IPRT, 1010) (NMVAR(I),I=1,6), VALMN
      RETURN
C
   20 WRITE (IPRT, 1020) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   34H MUST BE GREATER THAN OR EQUAL TO , G21.14, '.')
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   34H MUST BE GREATER THAN OR EQUAL TO , 8A1, '.')
C
      END
*ERSGT
      SUBROUTINE ERSGT(NMSUB, NMVAR, VAL, VALMN, MSGTYP, HEAD, ERROR,
     +   NMMIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THE ROUTINE CHECKS WHETHER THE VALUE   VAL   IS GREATER THAN
C        VALMN   , 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  -  JUNE 10, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   VAL,VALMN
      INTEGER
     +   MSGTYP
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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
C                   LIMITS BASED ON OTHER INPUT ARGUMENTS.
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     REAL VAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C     REAL VALMN
C        THE MINIMUM VALUE THE ARGUMENT CAN VALIDLY HAVE.
C
      ERROR = .FALSE.
C
      IF (VAL .GT. VALMN) RETURN
C
      ERROR = .TRUE.
      CALL IPRINT (IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL
C
      GO TO (10, 20), MSGTYP
C
   10 WRITE (IPRT, 1010) (NMVAR(I),I=1,6), VALMN
      RETURN
C
   20 WRITE (IPRT, 1020) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   22H MUST BE GREATER THAN , G21.14, '.')
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   22H MUST BE GREATER THAN , 8A1, '.')
C
      END
*ERSIE
      SUBROUTINE ERSIE(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 (EXCLUSIVE), 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
      REAL
     +   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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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     REAL VAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C     REAL VALMN, VALMX
C        THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE
C        ARGUMENT MUST LIE.
C
      ERROR = .FALSE.
C
      IF (((VALMN.LE.VAL) .AND. (VAL.LT.VALMX)) .OR.
     +   (VALMX.LT.VALMN)) RETURN
C
      ERROR = .TRUE.
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM
C     OTHER INPUT ARGUMENTS.
C
      IF (MSGTYP .EQ. 1)
     +   WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +      (NMMAX(I),I=1,8)
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC
C
      IF (MSGTYP .EQ. 2)
     +   WRITE (IPRT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   17H MUST LIE BETWEEN, 1X, 8A1, 12H (INCLUSIVE)/
     +   5H AND , 8A1, 13H (EXCLUSIVE).)
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   17H MUST LIE BETWEEN, 1X, G15.8, 12H (INCLUSIVE)/
     +   5H AND , G15.8, 13H (EXCLUSIVE).)
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
      REAL
     +   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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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     REAL VAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C     REAL VALMN, VALMX
C        THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE
C        ARGUMENT MUST LIE.
C
      ERROR = .FALSE.
C
      IF (((VALMN.LE.VAL) .AND. (VAL.LE.VALMX)) .OR.
     +   (VALMX.LT.VALMN)) RETURN
C
      ERROR = .TRUE.
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM
C     OTHER INPUT ARGUMENTS.
C
      IF (MSGTYP .EQ. 1)
     +   WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +      (NMMAX(I),I=1,8)
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC
C
      IF (MSGTYP .EQ. 2)
     +   WRITE (IPRT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.')
 1010 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   16H MUST BE BETWEEN, 1X, 8A1,
     +   5H AND , 8A1, 12H, INCLUSIVE.)
 1020 FORMAT(
     +   27H THE VALUE OF THE ARGUMENT , 6A1,
     +   16H MUST BE BETWEEN, 1X, G15.8,
     +   5H AND , G15.8, 12H, INCLUSIVE.)
C
      END
*ERSLF
      SUBROUTINE ERSLF (NMSUB, NMVAR, K, H, HEAD, ERROR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PERFORMS ERROR CHECKING FOR THE INPUT
C     VALUES OF A SYMMETRIC LINEAR 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
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      REAL
     +   H(*)
      CHARACTER
     +   NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IHM,IHP,IPRT,KHALF,KMID,NZERO
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL H(K)
C         THE VECTOR OF FILTER COEFFICIENTS.
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 IHM, IHP
C        INDEX VARIABLES FOR SYMMETRIC LOCATIONS AROUND THE MIDPOINT
C        OF THE FILTER.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
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     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     CHARACTER*1 NMVAR(8)
C        THE ARRAY CONTAINING THE NAME OF THE FILTER COEFFICIENT
C        ARRAY.
C     INTEGER NZERO
C        THE NUMBER OF FILTER COEFFICIENTS EQUAL TO ZERO.
C
      ERROR = .FALSE.
C
      KMID = (K + 1) / 2
      KHALF = KMID - 1
      NZERO = 0
      DO 10 IHM = 1, KHALF
         IHP = K + 1 - IHM
         IF (H(IHM) .EQ. 0.0E0) NZERO = NZERO + 1
         IF (H(IHM)  .EQ.  H(IHP)) GO TO 10
C
         CALL IPRINT(IPRT)
         CALL EHDR(NMSUB, HEAD)
         WRITE (IPRT, 1010) (NMVAR(I), I = 1, 6), (H(I), I = 1, K)
         ERROR = .TRUE.
         RETURN
   10 CONTINUE
C
      IF (H(KMID) .EQ. 0.0E0) NZERO = NZERO + 1
C
      IF (NZERO .LT. KMID) RETURN
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE (IPRT, 1020) (NMVAR(I), I = 1, 6)
      ERROR = .TRUE.
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(/
     +   18H THE INPUT FILTER , 6A1, 24H MUST BE SYMMETRIC.  THE,
     +   30H INPUT FILTER COEFFICIENTS ARE/
     +   5(1X, E15.5))
 1020 FORMAT(/
     +   32H ALL THE FILTER COEFFICIENTS IN , 6A1, 16H ARE IDENTICALLY,
     +   15H EQUAL TO ZERO,/
     +   42H THEREFORE NO FILTERING WILL BE PERFORMED.)
      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
      REAL
     +   FC
      INTEGER
     +   K
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      REAL
     +   TEMP
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL 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     REAL TEMP
C        A TEMPORARY VARIABLE USED FOR TYPE CONVERSION.
C
      ERROR = .FALSE.
      TEMP = K
C
      IF (FC - 1.0E0/TEMP .GE. 0.0E0) GO TO 10
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE (IPRT, 1010) FC, K
      ERROR = .TRUE.
      RETURN
C
   10 CONTINUE
C
      IF (FC + 1.0E0/K .LT. 0.5E0) RETURN
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE (IPRT, 1020) FC, K
      ERROR = .TRUE.
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT (/36H THE CUTOFF FREQUENCY, FC, MINUS ONE,
     +   41H OVER THE NUMBER OF FILTER TERMS, K, THAT/
     +   53H IS, FC - 1/K, MUST BE GREATER THAN OR EQUAL TO ZERO.,
     +   29H THE INPUT VALUES OF FC AND K/
     +   4H ARE, F8.5, 4H AND, I5, 15H, RESPECTIVELY.)
 1020 FORMAT (/35H THE CUTOFF FREQUENCY, FC, PLUS ONE,
     +   45H OVER THE NUMBER OF FILTER TERMS, K, THAT IS,/
     +   49H FC + 1/K, MUST BE GREATER THAN OR EQUAL TO ZERO.,
     +   29H THE INPUT VALUES OF FC AND K/
     +   4H ARE, F7.5, 4H AND, I5, 15H, RESPECTIVELY.)
C
      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
      REAL
     +   VECLB
      INTEGER
     +   MSGTYP,N,NV,NVMX
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      REAL
     +   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     REAL VEC(N)
C        THE VECTOR BEING TESTED.
C     REAL VECLB
C        THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST.
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
*ERVGTM
      SUBROUTINE ERVGTM (NMSUB, NMVAR, VEC, VCMISS, 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     VALUES OF VEC EQUAL TO VCMISS ARE EXEMPTED FROM THE CHECKING.
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
      REAL
     +   VCMISS,VECLB
      INTEGER
     +   MSGTYP,N,NV,NVMX
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      REAL
     +   VEC(*)
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,NVMN
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      EXTERNAL MVCHK
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     REAL VCMISS
C        MISSING VALUE CODE IN VEC.
C     REAL VEC(N)
C        THE VECTOR BEING TESTED.
C     REAL VECLB
C        THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST.
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 (MVCHK(VEC(I), VCMISS)) GO TO 5
         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
*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
      REAL
     +   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,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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     REAL VECLB
C        THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST.
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      IF (MSGTYP.LE.3) THEN
        WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VECLB, NV
      ELSE
        IF (MSGTYP.GE.7) THEN
          WRITE (IPRT, 1001) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV
        ELSE
          WRITE (IPRT, 1002) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV
        END IF
      END IF
C
      GO TO (10, 20, 30, 40, 50, 60, 70), MSGTYP
C
   10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6), VECLB
      RETURN
C
   20 WRITE(IPRT, 1020) (NMVAR(I),I=1,3), VECLB, NVMX
      RETURN
C
   30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6), VECLB, VECLB
      RETURN
C
   40 WRITE(IPRT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      RETURN
C
   50 WRITE(IPRT, 1050) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NVMX
      RETURN
C
   60 WRITE(IPRT, 1060) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +   (NMMIN(I),I=1,8)
      RETURN
C
   70 WRITE(IPRT, 1070) NVMN, (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/
     +   32H THE NUMBER OF VALUES IN VECTOR , 6A1,
     +   23H LESS THAN OR EQUAL TO , 1PE14.7, 4H IS , I6, '.')
 1001 FORMAT (/
     +   32H THE NUMBER OF VALUES IN VECTOR , 6A1,
     +  ' GREATER THAN ', 8A1, ' IS ', I2, '.')
 1002 FORMAT (/
     +   32H THE NUMBER OF VALUES IN VECTOR , 6A1,
     +   23H LESS THAN OR EQUAL TO , 8A1, 4H IS , I6, '.')
 1010 FORMAT(
     +   26H THE VALUES IN THE VECTOR , 6A1,
     +   26H MUST ALL BE GREATER THAN , 1PE14.7, '.')
 1020 FORMAT(
     +   36H THE NUMBER OF VALUES IN THE VECTOR , 6A1,
     +   23H LESS THAN OR EQUAL TO , 1PE14.7/
     +   19H MUST BE LESS THAN , I5, '.')
 1030 FORMAT(
     +   37H SINCE THE FIRST VALUE OF THE VECTOR , 6A1,
     +   17H IS GREATER THAN , 1PE14.7/
     +   40H ALL OF THE VALUES MUST BE GREATER THAN , 1PE14.7, '.')
 1040 FORMAT(
     +   26H THE VALUES IN THE VECTOR , 6A1,
     +   26H MUST ALL BE GREATER THAN , 8A1, '.')
 1050 FORMAT(
     +   36H THE NUMBER OF VALUES IN THE VECTOR , 6A1,
     +   23H LESS THAN OR EQUAL TO , 8A1/
     +   19H MUST BE LESS THAN , I5, '.')
 1060 FORMAT(
     +   37H SINCE THE FIRST VALUE OF THE VECTOR , 6A1,
     +   17H IS GREATER THAN , 8A1/
     +   40H ALL OF THE VALUES MUST BE GREATER THAN , 8A1, '.')
 1070 FORMAT(/' THERE MUST BE AT LEAST ', I2, ' VALUES IN VECTOR ', 6A1/
     +  ' GREATER THAN OR EQUAL TO ', 8A1, '.')
C
      END
*ERVII
      SUBROUTINE ERVII (NMSUB, NMVAR, Y, N, YLB, YUB, NVMX,
     +   HEAD, MSGTYP, NV, ERROR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS FOR VALUES IN THE INPUT VECTOR   Y
C     WHICH ARE OUTSIDE THE (INCLUSIVE) LIMITS YLB TO YUB, PRINTS
C     AN ERROR MESSAGE IF THE NUMBER OF VIOLATIONS EXCEEDS THE LARGEST
C     NUMBER OF VIOLATIONS ALLOWED, AND RETURNS THE NUMBER OF
C     VIOLATIONS AND AN ERROR FLAG INDICATING THE RESULTS.  THREE
C     MESSAGES ARE AVAILABLE, SPECIFIED BY    MSGTYP   .
C        IF (MSGTYP = 0) NO VIOLATIONS ARE ALLOWED.
C        IF (MSGTYP = 1) THE NUMBER OF VIOLATIONS MUST
C                        BE LESS THAN   NVMX   .
C        IF (MSGTYP = 2) VIOLATIONS ARE COUNTED ONLY IF THE
C                        THE FIRST ELEMENT IS NOT IN VIOLATION.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YLB,YUB
      INTEGER
     +   MSGTYP,N,NV,NVMX
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
      CHARACTER
     +   NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,NNV,NNVMN
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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 VARIABLE.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MSGTYP
C        THE INDICATOR VARIABLE FOR THE TYPE OF MESSAGE.
C        IF (MSGTYP = 0) NO VIOLATIONS ARE ALLOWED.
C        IF (MSGTYP = 1) THE NUMBER OF VIOLATIONS MUST
C                        BE LESS THAN   NVMX   .
C        IF (MSGTYP = 2) 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 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE PARAMETERS NAME.
C     INTEGER NNV
C        THE NUMBER OF VALUES NOT IN VIOLATION.
C     INTEGER NNVMN
C        THE SMALLEST NUMBER OF VALUES NOT IN VIOLATION ALLOWED.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND.
C     INTEGER NVMX
C        THE LARGEST NUMBER OF VIOLATIONS ALLOWED.
C     REAL Y(N)
C        THE VECTOR BEING TESTED.
C     REAL YLB, YUB
C        THE (INCLUSIVE) RANGE THAT THE VECTOR IS BEING TESTED
C        AGAINST.
C
      ERROR = .FALSE.
C
      IF (N .LE. 0) RETURN
C
C     TEST WHETHER TESTING IS NECESSRY
C
      IF ((MSGTYP .EQ. 2) .AND.
     +    (Y(1) .LT. YLB) .OR. (Y(1) .GT. YUB)) RETURN
C
C     CHECK FOR VIOLATIONS
C
      NV = 0
      DO 10 I = 1, N
         IF ((Y(I).LT.YLB) .OR. (Y(I).GT.YUB)) NV = NV + 1
   10 CONTINUE
C
      IF (NV .LE. NVMX) RETURN
C
C     VIOLATIONS FOUND
C
      ERROR = .TRUE.
      CALL IPRINT(IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      NNV = N - NV
      NNVMN = N - NVMX
C
      IF (MSGTYP .EQ. 0)
     +   WRITE(IPRT, 1010) (NMVAR(I), I = 1, 6), YLB, YUB, NV
      IF (MSGTYP .EQ. 1)
     +   WRITE(IPRT, 1020) (NMVAR(I), I = 1, 6), YLB, YUB,
     +   NNVMN, NNV
      IF (MSGTYP .EQ. 2)
     +   WRITE(IPRT, 1030) (NMVAR(I), I = 1, 6), YLB, YUB
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(/
     +   26H THE VALUES IN THE VECTOR , 6A1,
     +   26H MUST ALL BE IN THE RANGE , 1PE14.7, 3H TO/
     +   1X, 1PE14.7,
     +      52H, INCLUSIVE. THE NUMBER OF VALUES OUTSIDE THIS RANGE,
     +   4H IS , I5, '.')
 1020 FORMAT(/
     +   36H THE NUMBER OF VALUES IN THE VECTOR , 6A1,
     +   14H IN THE RANGE , 1PE14.7, 3H TO/
     +   1X, 1PE14.7, 34H, INCLUSIVE, MUST EQUAL OR EXCEED , I5, '.'/
     +   ' THE NUMBER OF VALUES IN THIS RANGE IS ', I5, '.')
 1030 FORMAT(/
     +   34H IF THE FIRST VALUE OF THE VECTOR , 6A1,
     +   16H IS IN THE RANGE, 1PE14.7, 3H TO/
     +   1X, 1PE14.7,
     +      52H INCLUSIVE, ALL OF THE VALUES MUST BE IN THIS RANGE.)
C
      END
*ERVWT
      SUBROUTINE ERVWT (NMSUB, NMVAR1, WT, N, NNZWMN, HEAD, NNZW,
     +   NZW, MSGTYP, ERROR, NMVAR2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS USER SUPPLIED WEIGHTS TO ASSURE THERE
C     ARE NO NEGATIVE WEIGHTS, AND THAT THERE ARE SUFFICIENT POSITIVE
C     WEIGHTS FOR THE TASK.  IT RETURNS ERROR SET TO TRUE
C     IF NO ERRORS ARE FOUND, AND SET TO FALSE OTHERWISE, AND IN
C     ADDITION, RETURNS THE NUMBER OF NONZERO WEIGHTS AND THE NUMBER
C     OF ZERO WEIGHTS.
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,N,NNZW,NNZWMN,NZW
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      REAL
     +   WT(*)
      CHARACTER
     +   NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR,IPRINT
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 ON LIMITS
C                    IMPOSED BY STARPAC.
C        MSGTYP = 2, THE INPUT VALUE WAS TOO SMALL BASED ON OTHER
C                    INPUT ARGUMENTS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
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 NNZW
C        THE NUMBER OF NONZERO WEIGHTS.
C     INTEGER NNZWMN
C        THE MINIMUM NUMBER OF NONZERO WEIGHTS WHICH IS ACCEPTABLE.
C     INTEGER NZW
C        THE NUMBER OF ZERO WEIGHTS.
C     REAL WT(N)
C        THE WEIGHT VECTOR.
C
      ERROR = .FALSE.
C
      IF (N.LE.0) RETURN
C
C     CHECK FOR NEGATIVE WEIGHTS AND COUNT NUMBER OF ZERO WEIGHTS.
C
      NZW = 0
      DO 10 I = 1, N
         IF (WT(I) .LT. 0.0E0) GO TO 20
         IF (WT(I) .EQ. 0.0E0) NZW = NZW + 1
   10 CONTINUE
C
      NNZW = N - NZW
      IF (NNZW .GE. NNZWMN) RETURN
C
C     INSUFFICIENT NUMBER OF POSITIVE WEIGHTS FOUND
C
      ERROR = .TRUE.
C
      CALL IPRINT(IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE (IPRT, 1010) NNZW
      IF (MSGTYP.EQ.1) WRITE(IPRT, 1030) (NMVAR1(I), I=1,6), NNZWMN
      IF (MSGTYP.EQ.2) WRITE(IPRT,1040) (NMVAR1(I),I=1,6),
     +   (NMVAR2(I),I=1,8)
C
      RETURN
C
C     NEGATIVE WEIGHTS FOUND
C
   20 ERROR = .TRUE.
C
      CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE(IPRT, 1020) (NMVAR1(I), I = 1, 6)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(/
     +   40H THE NUMBER OF NONZERO WEIGHTS FOUND IS , I6, '.')
 1020 FORMAT(/
     +   42H NEGATIVE VALUES WERE FOUND IN THE VECTOR , 6A1, '.'/
     +   51H ALL WEIGHTS MUST BE GREATER THAN OR EQUAL TO ZERO.)
 1030 FORMAT(
     +   34H THE NUMBER OF NONZERO WEIGHTS IN , 6A1,
     +   34H MUST BE GREATER THAN OR EQUAL TO , I6, '.')
 1040 FORMAT(
     +   34H THE NUMBER OF NONZERO WEIGHTS IN , 6A1,
     +   34H MUST BE GREATER THAN OR EQUAL TO , 8A1, '.')
C
      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
      REAL
     +   ETA
      INTEGER
     +   IXM,M,N,NETA,NPAR,NROWIN
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PARTMP(NPAR),PV(N),XM(IXM,M)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  LOCAL SCALARS
      REAL
     +   A,B,FAC,FPLRS,J,RSSSM,RSSSMJ,SQRTMP
      INTEGER
     +   I,K,NROW
C
C  LOCAL ARRAYS
      REAL
     +   RSS(5)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SETROW
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG10,MAX,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL A, B
C        PARAMETERS OF THE FIT.
C     REAL ETA
C        THE NOISE IN THE MODEL RESULTS.
C     REAL FAC
C        A FACTOR USED IN THE COMPUTATIONS.
C     REAL 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     REAL 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     REAL PAR(NPAR)
C        MODEL PARAMETERS
C     REAL PARTMP(NPAR)
C        MODIFIED MODEL PARAMETERS
C     REAL PV(N)
C        PREDICTED VALUES
C     REAL RSS(5)
C        THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J.
C     REAL RSSSM
C        THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF
C        PARAMETER VALUES.
C     REAL RSSSMJ
C        THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH
C        SET OF PARAMETER VALUES.
C     REAL SQRTMP
C        THE SQUARE ROOT OF MACHINE PRECISION (FPLRS).
C     REAL XM(IXM,M)
C        INDEPENDENT VARIABLES
C
      FPLRS = R1MACH(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.0E0
      RSSSMJ = 0.0E0
      DO 20 I=1,5
         J = I-3
         DO 10 K=1,NPAR
            PARTMP(K) = PAR(K)*(1.0E0+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.2E00*RSSSM
      B = 0.1E00*RSSSMJ
      FAC = 1.0E0
      IF (RSS(3).NE.0.0E0) 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.0E0**(-NETA)
      RETURN
      END
*EXTEND
      REAL FUNCTION EXTEND(X, I, N, SYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C      THIS FUNCTION RETURNS THE ITH TERM IN THE SERIES X,
C     EXTENDING IF NECESSARY WITH EVEN OR ODD SYMMETRY ACCORDING
C     TO THE SIGN OF SYM, WHICH SHOULD BE EITHER PLUS OR MINUS ONE.
C     (THE VALUE ZERO WILL RESULT IN THE EXTENDED VALUE BEING ZERO.)
C     THIS ROUTINE IS TAKEN FROM BLOOMFIELDS BOOK, PAGE 179.
C
C     WRITTEN BY  -  PETER BLOOMFIELD
C     CODED BY  -  JANET R. DONALDSON
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
      REAL
     +   SYM
      INTEGER
     +   I,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N)
C
C  LOCAL SCALARS
      REAL
     +   CON
      INTEGER
     +   J
C
      J = I
      CON = 1.0E0
   10 IF (J .GE. 1) GO TO 20
      J = 2-J
      CON = CON * SYM
   20 IF (J .LE. N) GO TO 30
      J = 2*N-J
      CON = CON * SYM
      GO TO 10
   30 EXTEND = X(J)*CON
C
      RETURN
C
      END
*FACTOR
      SUBROUTINE FACTOR(N, NPF, IPF, IPFEXP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE FACTORS AN INPUT INTEGER   N   AND RETURNS
C     THE NUMBER OF PRIME FACTORS IN   NPF   , THE VALUE OF THE
C     PRIME FACTORS IN THE VECTOR   IPF   , AND THE EXPONENT
C     OF EACH OF THE PRIME FACTORS IN THE VECTOR   IPFEXP   .
C     THE ELEMENTS OF    IPF   ARE STORED IN INCREASING ORDER.
C     THE LENGTH OF THE VECTORS IS SUFFICIENT TO ACCOMODATE
C     THE PRIME FACTORS OF AN INTEGER UP TO 2 ** 128 (APPROXIMATELY
C     10 ** 40).
C
C     THIS ROUTINE IS ADAPTED FROM THE FACTORING ROUTINE GIVEN
C     IN ACM ALGORITHM 467 (CACM, 1973, VOL. 16, NO. 11, PAGE 692-694).
C
C     ADAPTED BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 23, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NPF
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IPF(50),IPFEXP(50)
C
C  LOCAL SCALARS
      INTEGER
     +   IDIV,IFCUR,IQUOT,NPART
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IDIV, IFCUR
C        VARIOUS VARIABLES USED TO FACTOR    N   .
C     INTEGER IPF(50), IPFEXP(50)
C        THE VECTORS OF PRIME FACTORS OF   N   , AND THEIR EXPONENTS,
C        RESPECTIVELY.
C     INTEGER IQUOT
C        A VARIABLE USED TO FACTOR   N   .
C     INTEGER N
C        THE VALUE TO BE FACTORED.
C     INTEGER NPART
C        A VARIABLE USED TO FACTOR   N   .
C     INTEGER NPF
C        THE NUMBER OF FACTORS FOUND IN    N   .
C
C  DETERMINE THE FACTORS OF N
C
      NPF = 0
      IFCUR = 0
      NPART = N
      IDIV = 2
   10 IQUOT = NPART/IDIV
      IF (NPART.NE.IDIV*IQUOT) GO TO 40
      IF (IDIV.LE.IFCUR) GO TO 20
      NPF = NPF + 1
      IPF(NPF) = IDIV
      IFCUR = IDIV
      IPFEXP(NPF) = 1
      GO TO 30
   20 IPFEXP(NPF) = IPFEXP(NPF) + 1
   30 NPART = IQUOT
      GO TO 10
   40 IF (IQUOT.LE.IDIV) GO TO 60
      IF (IDIV.GE.3) GO TO 50
      IDIV = 3
      GO TO 10
   50 IDIV = IDIV + 2
      GO TO 10
   60 IF (NPART.LE.1) RETURN
      IF (NPART.LE.IFCUR) GO TO 70
      NPF = NPF + 1
      IPF(NPF) = NPART
      IPFEXP(NPF) = 1
      RETURN
   70 IPFEXP(NPF) = IPFEXP(NPF) + 1
C
      RETURN
      END
*FDUMP
      SUBROUTINE FDUMP
C  THIS IS A DUMMY ROUTINE TO BE SENT OUT ON
C  THE PORT SEDIT TAPE
C
      RETURN
      END
*FFTCT
      SUBROUTINE FFTCT(X, N2, IX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     COSINE TRANSFORM OF N=2*N2 SYMMETRIC DATA POINTS
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IX,N2
C
C  ARRAY ARGUMENTS
      REAL
     +   X(IX)
C
C  LOCAL SCALARS
      REAL
     +   A2,AA,AB,CD,CN,EX,PI,SAVE,SD,SN
      INTEGER
     +   I,ISN,J,K,M,M1,N1,NK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FFT,GETPI,REALTR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AA, AB, A2
C     REAL CD, CN
C     REAL EX
C     INTEGER I, ISN
C     INTEGER IX
C        THE DIMENSION OF X.
C     INTEGER J
C     INTEGER K
C     INTEGER M, M1
C     INTEGER NK, N1
C     INTEGER N2
C        THE HALF LENGTH OF THE SYMMETRIC DATA ARRAY.  N2 MUST BE EVEN.
C     REAL PI
C        THE VALUE OF PI.
C     REAL SAVE, SD, SN
C     REAL X(IX)
C        THE N2+2 VECTOR WITH FIRST HALF OF SYMMETRIC DATA STORED IN
C        THE FIRST N2+1 LOCATIONS.  LOCATION N2+2 USED ONLY FOR
C        WORKSPACE.  THE COSINE TRANSFORM COEFFICIENTS ARE RETURNED
C        IN THE FIRST N2+1 LOCATIONS OF X.
C
      CALL GETPI(PI)
C
      A2 = 0.0E0
      N1 = N2 + 1
      DO 10 J=2,N2,2
         A2 = A2 + X(J)
   10 CONTINUE
      A2 = 2.0E0*A2
      M = N2/2
      M1 = M + 1
      EX = X(2)
      X(2) = 0.0E0
      IF (N1.LT.4) GO TO 30
      DO 20 I=4,N1,2
         SAVE = EX - X(I)
         EX = X(I)
         X(I) = SAVE
   20 CONTINUE
   30 X(N2+2) = 0.0E0
      ISN = -2
      CALL REALTR(X, X(2), M, ISN)
      CALL FFT(X, X(2), M, M, M, ISN)
      SD = PI / (2*N2)
      CD = 2.0E0*SIN(SD)**2
      SD = SIN(SD+SD)
      SN = 0.0E0
      CN = 1.0E0
      NK = N2 + 2
      DO 40 J=2,M1
         K = NK - J
         AA = X(J) + X(K)
         AB = (X(J)-X(K))*0.5E0
         EX = CN - (CD*CN+SD*SN)
         SN = (SD*CN-CD*SN) + SN
         CN = 0.5E0/(EX*EX+SN*SN) + 0.5E0
         SN = CN*SN
         CN = CN*EX
         EX = AB/SN
         X(J) = (AA+EX)*0.5E0
         X(K) = (AA-EX)*0.5E0
   40 CONTINUE
      EX = X(1)
      X(1) = EX + A2
      X(N2+1) = EX - A2
      X(N2+2) = 0.0E0
      RETURN
      END
*FFT
      SUBROUTINE FFT(A, B, NTOT, N, NSPAN, ISN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  MULTIVARIATE COMPLEX FOURIER TRANSFORM, COMPUTED IN PLACE
C    USING MIXED-RADIX FAST FOURIER TRANSFORM ALGORITHM.
C  BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968
C  ARRAYS A AND B ORIGINALLY HOLD THE REAL AND IMAGINARY
C    COMPONENTS OF THE DATA, AND RETURN THE REAL AND
C    IMAGINARY COMPONENTS OF THE RESULTING FOURIER COEFFICIENTS.
C  MULTIVARIATE DATA IS INDEXED ACCORDING TO THE Fortran
C    ARRAY ELEMENT SUCCESSOR FUNCTION, WITHOUT LIMIT
C    ON THE NUMBER OF IMPLIED MULTIPLE SUBSCRIPTS.
C    THE SUBROUTINE IS CALLED ONCE FOR EACH VARIATE.
C    THE CALLS FOR A MULTIVARIATE TRANSFORM MAY BE IN ANY ORDER.
C  NTOT IS THE TOTAL NUMBER OF COMPLEX DATA VALUES.
C  N IS THE DIMENSION OF THE CURRENT VARIABLE.
C  NSPAN/N IS THE SPACING OF CONSECUTIVE DATA VALUES
C    WHILE INDEXING THE CURRENT VARIABLE.
C  THE SIGN OF ISN DETERMINES THE SIGN OF THE COMPLEX
C    EXPONENTIAL, AND THE MAGNITUDE OF ISN IS NORMALLY ONE.
C  A TRI-VARIATE TRANSFORM WITH A(N1,N2,N3), B(N1,N2,N3)
C    IS COMPUTED BY
C      CALL FFT(A,B,N1*N2*N3,N1,N1,1)
C      CALL FFT(A,B,N1*N2*N3,N2,N1*N2,1)
C      CALL FFT(A,B,N1*N2*N3,N3,N1*N2*N3,1)
C  FOR A SINGLE-VARIATE TRANSFORM,
C    NTOT = N = NSPAN = (NUMBER OF COMPLEX DATA VALUES), F.G.
C      CALL FFT(A,B,N,N,N,1)
C  THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX
C    ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO
C    GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO
C    PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY
C    VALUES, E.G.
C      CALL FFT(A,A(2),NTOT,N,NSPAN,2)
C  ARRAYS AT(MAXF), CK(MAXF), BT(MAXF), SK(MAXF), AND NP(MAXP)
C    ARE USED FOR TEMPORARY STORAGE.  IF THE AVAILABEL STORAGE
C    IS INSUFFICIENT, THE PROGRAM IS TERMINATED BY A STOP.
C    MAXF MUST BE .GE. THE MAXIMUM PRIME FACTOR OF N.
C    MAXP MUST BE .GT. THE NUMBER OF PRIME FACTORS OF N.
C
C     NB. THE ABOVE DESCRIPTION OF MAXP APPEARS TO BE INCORRECT.
C         MAXP SEEMS TO BE THE MAXIMUM SIZE OF THE SQUARE FREE
C         PORTION K OF N.
C
C    IN ADDITION, IF THE SQUARE-FREE PORTION K OF N HAS TWO OR
C    MORE PRIME FACTORS, THEN MAXP MUST BE .GE. K-1.
C     DIMENSION A(1), B(1)
C  ARRAY STORAGE IN NFAC FOR A MAXIMUM OF 11 FACTORS OF N.
C  IF N HAS MORE THAN ONE SQUARE-FREE FACTOR, THE PRODUCT OF THE
C    SQUARE-FREE FACTORS MUST BE .LE. 210
C     DIMENSION NFAC(11), NP(209)
C  ARRAY STORAGE FOR MAXIMUM PRIME FACTOR OF 23
C     DIMENSION AT(23), CK(23), BT(23), SK(23)
C
C
C  VARIABLE DECLARATIONS
C
C  PARAMETERS
      INTEGER
     +   MAXF1
      PARAMETER (MAXF1=23)
      INTEGER
     +   MAXP1
      PARAMETER (MAXP1=209)
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISN,N,NSPAN,NTOT
C
C  ARRAY ARGUMENTS
      REAL
     +   A(*),B(*)
C
C  LOCAL SCALARS
      REAL
     +   AA,AJ,AJM,AJP,AK,AKM,AKP,BB,BJ,BJM,BJP,BK,BKM,BKP,C1,C2,C3,
     +   C72,CD,RAD,RADF,S1,S120,S2,S3,S72,SD
      INTEGER
     +   I,II,INC,IPRT,J,JC,JF,JJ,K,K1,K2,K3,K4,KK,KS,KSPAN,KSPNN,
     +   KT,M,MAXF,MAXP,NN,NT
C
C  LOCAL ARRAYS
      REAL
     +   AT(MAXF1),BT(MAXF1),CK(MAXF1),SK(MAXF1)
      INTEGER
     +   NFAC(11),NP(MAXP1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ATAN,COS,MOD,SIN,SQRT
C
C  EQUIVALENCES
      EQUIVALENCE (I,II)
C
C  THE FOLLOWING TWO CONSTANTS SHOULD AGREE WITH THE ARRAY DIMENSIONS.
      MAXF = MAXF1
      MAXP = MAXP1
      IF (N.LT.2) RETURN
C
C  INITIALIZE VARIABLES
C
      C1 = 0
      C2 = 0
      C3 = 0
      S1 = 0
      S2 = 0
      S3 = 0
      K1 = 0
      K2 = 0
      K3 = 0
      K4 = 0
C
      INC = ISN
      RAD = 8.0E0*ATAN(1.0E0)
      S72 = RAD/5.0E0
      C72 = COS(S72)
      S72 = SIN(S72)
      S120 = SQRT(0.75E0)
      IF (ISN.GE.0) GO TO 10
      S72 = -S72
      S120 = -S120
      RAD = -RAD
      INC = -INC
   10 NT = INC*NTOT
      KS = INC*NSPAN
      KSPAN = KS
      NN = NT - INC
      JC = KS/N
      RADF = RAD*JC*0.5E0
      I = 0
      JF = 0
C  DETERMINE THE FACTORS OF N
      M = 0
      K = N
      GO TO 30
   20 M = M + 1
      NFAC(M) = 4
      K = K/16
   30 IF (K-(K/16)*16.EQ.0) GO TO 20
      J = 3
      JJ = 9
      GO TO 50
   40 M = M + 1
      NFAC(M) = J
      K = K/JJ
   50 IF (MOD(K,JJ).EQ.0) GO TO 40
      J = J + 2
      JJ = J**2
      IF (JJ.LE.K) GO TO 50
      IF (K.GT.4) GO TO 60
      KT = M
      NFAC(M+1) = K
      IF (K.NE.1) M = M + 1
      GO TO 100
   60 IF (K-(K/4)*4.NE.0) GO TO 70
      M = M + 1
      NFAC(M) = 2
      K = K/4
   70 KT = M
      J = 2
   80 IF (MOD(K,J).NE.0) GO TO 90
      M = M + 1
      NFAC(M) = J
      K = K/J
   90 J = ((J+1)/2)*2 + 1
      IF (J.LE.K) GO TO 80
  100 IF (KT.EQ.0) GO TO 120
      J = KT
  110 M = M + 1
      NFAC(M) = NFAC(J)
      J = J - 1
      IF (J.NE.0) GO TO 110
C  COMPUTE FOURIER TRANSFORM
  120 SD = RADF/KSPAN
      CD = 2.0E0*SIN(SD)**2
      SD = SIN(SD+SD)
      KK = 1
      I = I + 1
      IF (NFAC(I).NE.2) GO TO 170
C  TRANSFORM FOR FACTOR OF 2 (INCLUDING ROTATION FACTOR)
      KSPAN = KSPAN/2
      K1 = KSPAN + 2
  130 K2 = KK + KSPAN
      AK = A(K2)
      BK = B(K2)
      A(K2) = A(KK) - AK
      B(K2) = B(KK) - BK
      A(KK) = A(KK) + AK
      B(KK) = B(KK) + BK
      KK = K2 + KSPAN
      IF (KK.LE.NN) GO TO 130
      KK = KK - NN
      IF (KK.LE.JC) GO TO 130
      IF (KK.GT.KSPAN) GO TO 360
  140 C1 = 1.0E0 - CD
      S1 = SD
  150 K2 = KK + KSPAN
      AK = A(KK) - A(K2)
      BK = B(KK) - B(K2)
      A(KK) = A(KK) + A(K2)
      B(KK) = B(KK) + B(K2)
      A(K2) = C1*AK - S1*BK
      B(K2) = S1*AK + C1*BK
      KK = K2 + KSPAN
      IF (KK.LT.NT) GO TO 150
      K2 = KK - NT
      C1 = -C1
      KK = K1 - K2
      IF (KK.GT.K2) GO TO 150
      AK = C1 - (CD*C1+SD*S1)
      S1 = (SD*C1-CD*S1) + S1
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION ERROR
      C1 = 0.5E0/(AK**2+S1**2) + 0.5E0
      S1 = C1*S1
      C1 = C1*AK
      KK = KK + JC
      IF (KK.LT.K2) GO TO 150
      K1 = K1 + INC + INC
      KK = (K1-KSPAN)/2 + JC
      IF (KK.LE.JC+JC) GO TO 140
      GO TO 120
C  TRANSFORM FOR FACTOR OF 3 (OPTIONAL CODE)
  160 K1 = KK + KSPAN
      K2 = K1 + KSPAN
      AK = A(KK)
      BK = B(KK)
      AJ = A(K1) + A(K2)
      BJ = B(K1) + B(K2)
      A(KK) = AK + AJ
      B(KK) = BK + BJ
      AK = -0.5E0*AJ + AK
      BK = -0.5E0*BJ + BK
      AJ = (A(K1)-A(K2))*S120
      BJ = (B(K1)-B(K2))*S120
      A(K1) = AK - BJ
      B(K1) = BK + AJ
      A(K2) = AK + BJ
      B(K2) = BK - AJ
      KK = K2 + KSPAN
      IF (KK.LT.NN) GO TO 160
      KK = KK - NN
      IF (KK.LE.KSPAN) GO TO 160
      GO TO 320
C  TRANSFORM FOR FACTOR OF 4
  170 IF (NFAC(I).NE.4) GO TO 260
      KSPNN = KSPAN
      KSPAN = KSPAN/4
  180 C1 = 1.0E0
      S1 = 0
  190 K1 = KK + KSPAN
      K2 = K1 + KSPAN
      K3 = K2 + KSPAN
      AKP = A(KK) + A(K2)
      AKM = A(KK) - A(K2)
      AJP = A(K1) + A(K3)
      AJM = A(K1) - A(K3)
      A(KK) = AKP + AJP
      AJP = AKP - AJP
      BKP = B(KK) + B(K2)
      BKM = B(KK) - B(K2)
      BJP = B(K1) + B(K3)
      BJM = B(K1) - B(K3)
      B(KK) = BKP + BJP
      BJP = BKP - BJP
      IF (ISN.LT.0) GO TO 220
      AKP = AKM - BJM
      AKM = AKM + BJM
      BKP = BKM + AJM
      BKM = BKM - AJM
      IF (S1.EQ.0.0E0) GO TO 230
  200 A(K1) = AKP*C1 - BKP*S1
      B(K1) = AKP*S1 + BKP*C1
      A(K2) = AJP*C2 - BJP*S2
      B(K2) = AJP*S2 + BJP*C2
      A(K3) = AKM*C3 - BKM*S3
      B(K3) = AKM*S3 + BKM*C3
      KK = K3 + KSPAN
      IF (KK.LE.NT) GO TO 190
  210 C2 = C1 - (CD*C1+SD*S1)
      S1 = (SD*C1-CD*S1) + S1
      C1 = 0.5E0/(C2**2+S1**2) + 0.5E0
      S1 = C1*S1
      C1 = C1*C2
      C2 = C1**2 - S1**2
      S2 = 2.0E0*C1*S1
      C3 = C2*C1 - S2*S1
      S3 = C2*S1 + S2*C1
      KK = KK - NT + JC
      IF (KK.LE.KSPAN) GO TO 190
      KK = KK - KSPAN + INC
      IF (KK.LE.JC) GO TO 180
      IF (KSPAN.EQ.JC) GO TO 360
      GO TO 120
  220 AKP = AKM + BJM
      AKM = AKM - BJM
      BKP = BKM - AJM
      BKM = BKM + AJM
      IF (S1.NE.0.0E0) GO TO 200
  230 A(K1) = AKP
      B(K1) = BKP
      A(K2) = AJP
      B(K2) = BJP
      A(K3) = AKM
      B(K3) = BKM
      KK = K3 + KSPAN
      IF (KK.LE.NT) GO TO 190
      GO TO 210
C  TRANSFORM FOR FACTOR OF 5 (OPTIONAL CODE)
  240 C2 = C72**2 - S72**2
      S2 = 2.0E0*C72*S72
  250 K1 = KK + KSPAN
      K2 = K1 + KSPAN
      K3 = K2 + KSPAN
      K4 = K3 + KSPAN
      AKP = A(K1) + A(K4)
      AKM = A(K1) - A(K4)
      BKP = B(K1) + B(K4)
      BKM = B(K1) - B(K4)
      AJP = A(K2) + A(K3)
      AJM = A(K2) - A(K3)
      BJP = B(K2) + B(K3)
      BJM = B(K2) - B(K3)
      AA = A(KK)
      BB = B(KK)
      A(KK) = AA + AKP + AJP
      B(KK) = BB + BKP + BJP
      AK = AKP*C72 + AJP*C2 + AA
      BK = BKP*C72 + BJP*C2 + BB
      AJ = AKM*S72 + AJM*S2
      BJ = BKM*S72 + BJM*S2
      A(K1) = AK - BJ
      A(K4) = AK + BJ
      B(K1) = BK + AJ
      B(K4) = BK - AJ
      AK = AKP*C2 + AJP*C72 + AA
      BK = BKP*C2 + BJP*C72 + BB
      AJ = AKM*S2 - AJM*S72
      BJ = BKM*S2 - BJM*S72
      A(K2) = AK - BJ
      A(K3) = AK + BJ
      B(K2) = BK + AJ
      B(K3) = BK - AJ
      KK = K4 + KSPAN
      IF (KK.LT.NN) GO TO 250
      KK = KK - NN
      IF (KK.LE.KSPAN) GO TO 250
      GO TO 320
C  TRANSFORM FOR ODD FACTORS
  260 K = NFAC(I)
      KSPNN = KSPAN
      KSPAN = KSPAN/K
      IF (K.EQ.3) GO TO 160
      IF (K.EQ.5) GO TO 240
      IF (K.EQ.JF) GO TO 280
      JF = K
      S1 = RAD/K
      C1 = COS(S1)
      S1 = SIN(S1)
      IF (JF.GT.MAXF) GO TO 590
      CK(JF) = 1.0E0
      SK(JF) = 0.0E0
      J = 1
  270 CK(J) = CK(K)*C1 + SK(K)*S1
      SK(J) = CK(K)*S1 - SK(K)*C1
      K = K - 1
      CK(K) = CK(J)
      SK(K) = -SK(J)
      J = J + 1
      IF (J.LT.K) GO TO 270
  280 K1 = KK
      K2 = KK + KSPNN
      AA = A(KK)
      BB = B(KK)
      AK = AA
      BK = BB
      J = 1
      K1 = K1 + KSPAN
  290 K2 = K2 - KSPAN
      J = J + 1
      AT(J) = A(K1) + A(K2)
      AK = AT(J) + AK
      BT(J) = B(K1) + B(K2)
      BK = BT(J) + BK
      J = J + 1
      AT(J) = A(K1) - A(K2)
      BT(J) = B(K1) - B(K2)
      K1 = K1 + KSPAN
      IF (K1.LT.K2) GO TO 290
      A(KK) = AK
      B(KK) = BK
      K1 = KK
      K2 = KK + KSPNN
      J = 1
  300 K1 = K1 + KSPAN
      K2 = K2 - KSPAN
      JJ = J
      AK = AA
      BK = BB
      AJ = 0.0E0
      BJ = 0.0E0
      K = 1
  310 K = K + 1
      AK = AT(K)*CK(JJ) + AK
      BK = BT(K)*CK(JJ) + BK
      K = K + 1
      AJ = AT(K)*SK(JJ) + AJ
      BJ = BT(K)*SK(JJ) + BJ
      JJ = JJ + J
      IF (JJ.GT.JF) JJ = JJ - JF
      IF (K.LT.JF) GO TO 310
      K = JF - J
      A(K1) = AK - BJ
      B(K1) = BK + AJ
      A(K2) = AK + BJ
      B(K2) = BK - AJ
      J = J + 1
      IF (J.LT.K) GO TO 300
      KK = KK + KSPNN
      IF (KK.LE.NN) GO TO 280
      KK = KK - NN
      IF (KK.LE.KSPAN) GO TO 280
C  MULTIPLY BY ROTATION FACTOR (EXCEPT FOR FACTORS OF 2 AND 4)
  320 IF (I.EQ.M) GO TO 360
      KK = JC + 1
  330 C2 = 1.0E0 - CD
      S1 = SD
  340 C1 = C2
      S2 = S1
      KK = KK + KSPAN
  350 AK = A(KK)
      A(KK) = C2*AK - S2*B(KK)
      B(KK) = S2*AK + C2*B(KK)
      KK = KK + KSPNN
      IF (KK.LE.NT) GO TO 350
      AK = S1*S2
      S2 = S1*C2 + C1*S2
      C2 = C1*C2 - AK
      KK = KK - NT + KSPAN
      IF (KK.LE.KSPNN) GO TO 350
      C2 = C1 - (CD*C1+SD*S1)
      S1 = S1 + (SD*C1-CD*S1)
      C1 = 0.5E0/(C2**2+S1**2) + 0.5E0
      S1 = C1*S1
      C2 = C1*C2
      KK = KK - KSPNN + JC
      IF (KK.LE.KSPAN) GO TO 340
      KK = KK - KSPAN + JC + INC
      IF (KK.LE.JC+JC) GO TO 330
      GO TO 120
C  PERMUTE THE RESULTS TO NORMAL ORDER--- DONE IN TWO STAGES
C  PERMUTATION FOR SQUARE FACTORS OF N
  360 NP(1) = KS
      IF (KT.EQ.0) GO TO 450
      K = KT + KT + 1
      IF (M.LT.K) K = K - 1
      J = 1
      NP(K+1) = JC
  370 NP(J+1) = NP(J)/NFAC(J)
      NP(K) = NP(K+1)*NFAC(J)
      J = J + 1
      K = K - 1
      IF (J.LT.K) GO TO 370
      K3 = NP(K+1)
      KSPAN = NP(2)
      KK = JC + 1
      K2 = KSPAN + 1
      J = 1
      IF (N.NE.NTOT) GO TO 410
C  PERMUTATION FOR SINGLE-VARIATE TRANSFORM (OPTIONAL CODE)
  380 AK = A(KK)
      A(KK) = A(K2)
      A(K2) = AK
      BK = B(KK)
      B(KK) = B(K2)
      B(K2) = BK
      KK = KK + INC
      K2 = KSPAN + K2
      IF (K2.LT.KS) GO TO 380
  390 K2 = K2 - NP(J)
      J = J + 1
      K2 = NP(J+1) + K2
      IF (K2.GT.NP(J)) GO TO 390
      J = 1
  400 IF (KK.LT.K2) GO TO 380
      KK = KK + INC
      K2 = KSPAN + K2
      IF (K2.LT.KS) GO TO 400
      IF (KK.LT.KS) GO TO 390
      JC = K3
      GO TO 450
C  PERMUTATION FOR MULTIVARIATE TRANSFORM
  410 K = KK + JC
  420 AK = A(KK)
      A(KK) = A(K2)
      A(K2) = AK
      BK = B(KK)
      B(KK) = B(K2)
      B(K2) = BK
      KK = KK + INC
      K2 = K2 + INC
      IF (KK.LT.K) GO TO 420
      KK = KK + KS - JC
      K2 = K2 + KS - JC
      IF (KK.LT.NT) GO TO 410
      K2 = K2 - NT + KSPAN
      KK = KK - NT + JC
      IF (K2.LT.KS) GO TO 410
  430 K2 = K2 - NP(J)
      J = J + 1
      K2 = NP(J+1) + K2
      IF (K2.GT.NP(J)) GO TO 430
      J = 1
  440 IF (KK.LT.K2) GO TO 410
      KK = KK + JC
      K2 = KSPAN + K2
      IF (K2.LT.KS) GO TO 440
      IF (KK.LT.KS) GO TO 430
      JC = K3
  450 IF (2*KT+1.GE.M) RETURN
      KSPNN = NP(KT+1)
C  PERMUTATION FOR SQUARE-FREE FACTORS OF N
      J = M - KT
      NFAC(J+1) = 1
  460 NFAC(J) = NFAC(J)*NFAC(J+1)
      J = J - 1
      IF (J.NE.KT) GO TO 460
      KT = KT + 1
      NN = NFAC(KT) - 1
      IF (NN.GT.MAXP) GO TO 590
      JJ = 0
      J = 0
      GO TO 490
  470 JJ = JJ - K2
      K2 = KK
      K = K + 1
      KK = NFAC(K)
  480 JJ = KK + JJ
      IF (JJ.GE.K2) GO TO 470
      NP(J) = JJ
  490 K2 = NFAC(KT)
      K = KT + 1
      KK = NFAC(K)
      J = J + 1
      IF (J.LE.NN) GO TO 480
C  DETERMINE THE PERMUTATION CYCLES OF LENGTH GREATER THAN 1
      J = 0
      GO TO 510
  500 K = KK
      KK = NP(K)
      NP(K) = -KK
      IF (KK.NE.J) GO TO 500
      K3 = KK
  510 J = J + 1
      KK = NP(J)
      IF (KK.LT.0) GO TO 510
      IF (KK.NE.J) GO TO 500
      NP(J) = -J
      IF (J.NE.NN) GO TO 510
      MAXF = INC*MAXF
C  REORDER A AND B, FOLLOWING THE PERMUTATION CYCLES
      GO TO 580
  520 J = J - 1
      IF (NP(J).LT.0) GO TO 520
      JJ = JC
  530 KSPAN = JJ
      IF (JJ.GT.MAXF) KSPAN = MAXF
      JJ = JJ - KSPAN
      K = NP(J)
      KK = JC*K + II + JJ
      K1 = KK + KSPAN
      K2 = 0
  540 K2 = K2 + 1
      AT(K2) = A(K1)
      BT(K2) = B(K1)
      K1 = K1 - INC
      IF (K1.NE.KK) GO TO 540
  550 K1 = KK + KSPAN
      K2 = K1 - JC*(K+NP(K))
      K = -NP(K)
  560 A(K1) = A(K2)
      B(K1) = B(K2)
      K1 = K1 - INC
      K2 = K2 - INC
      IF (K1.NE.KK) GO TO 560
      KK = K2
      IF (K.NE.J) GO TO 550
      K1 = KK + KSPAN
      K2 = 0
  570 K2 = K2 + 1
      A(K1) = AT(K2)
      B(K1) = BT(K2)
      K1 = K1 - INC
      IF (K1.NE.KK) GO TO 570
      IF (JJ.NE.0) GO TO 530
      IF (J.NE.1) GO TO 520
  580 J = K3 + 1
      NT = NT - KSPNN
      II = NT - INC + 1
      IF (NT.GE.0) GO TO 520
      RETURN
C  ERROR FINISH, INSUFFICIENT ARRAY STORAGE
  590 ISN = 0
      CALL IPRINT(IPRT)
      WRITE(IPRT, 1000)
C
C     NB.  THE FOLLOWING STOP SHOULD BE CHANGED TO A RETURN WHEN
C          THE TIME SERIES ROUTINES ARE MODIFIED FOR STARPAC.
C
      STOP
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (' ', 17('*')/18H * ERROR MESSAGE */1X, 17('*')//
     +   45H ARRAY BOUNDS EXCEEDED WITHIN SUBROUTINE FFT./
     +   44H PLEASE BRING THIS ERROR TO THE ATTENTION OF/
     +   22H    JANET R. DONALDSON/
     +   16H    303-497-5114/
     +   16H    FTS 320-5114)
      END
*FFTLEN
      SUBROUTINE FFTLEN(N, NDIV, NFFT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE SMALLEST VALUE OF NFFT WHICH
C     EQUALS OR EXCEEDS N + 2, SUCH THAT NFFT - 2 IS DIVISIBLE BY
C     NDIV AND HAS NO PRIME FACTORS GREATER THAN 23, AND THE
C     PRODUCT OF THE NON SQUARE PRIME FACTORS OF NFFT - 2 DO NOT
C     EXCEED 209.  THE VALUE OF NFFT THUS MEET THE REQUIREMENTS OF
C     THE EXTENDED LENGTH OF THE SERIES REQUIRED FOR ANY ROUTINE
C     USING THE SINGLETON FFT PROVIDING THE PROPER VALUE OF NDIV
C     IS CHOSEN.
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
     +   N,NDIV,NFFT
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      LOGICAL
     +   ERR01,ERR02,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LN(8)*1,LNDIV(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,IPRINT,SETESL
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02
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 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 WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     CHARACTER*1 LN(8), LNDIV(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER N
C        THE NUMBER UPON WHICH NFFT IS BASED.
C     INTEGER NDIV
C        A REQUIRED FACTOR OF NFFT - 2.
C     INTEGER NFFT
C        THE RETURNED VALUE WHICH MEETS THE ABOVE DESCRIPTION.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINE.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'F',       'F',       'T',       'L',       'E',       'N'/
      DATA
     +     LN(1),     LN(2),     LN(3),     LN(4),     LN(5),     LN(6)
     + /     'N',       ' ',       ' ',       ' ',       ' ',       ' '/
      DATA
     +     LN(7),     LN(8)
     + /     ' ',       ' '/
      DATA
     +  LNDIV(1),  LNDIV(2),  LNDIV(3),  LNDIV(4),  LNDIV(5),  LNDIV(6)
     + /     'N',       'D',       'I',       'V',       ' ',       ' '/
      DATA
     +  LNDIV(7),  LNDIV(8)
     + /     ' ',       ' '/
C
C     ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
      CALL EISGE(NMSUB, LN, N, 1, 1, HEAD, ERR01, LN)
C
      CALL EISGE(NMSUB, LNDIV, NDIV, 1, 1, HEAD, ERR02, LNDIV)
C
C
      IF ((.NOT. ERR01) .AND. (.NOT. ERR02)) GO TO 10
C
C     PRINT PROPER CALL SEQUENCE
C
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
C
      RETURN
C
   10 CONTINUE
C
      CALL SETESL(N, NDIV, NFFT)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   34H       CALL FFTLEN (N, NDIV, NFFT))
C
      END
*FFTR
      SUBROUTINE FFTR (YFFT, N, NFFT, IEXTND, NF, AB, LAB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING
C     THE FOURIER TRANSFORM OF A SERIES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   IEXTND,LAB,N,NF,NFFT
C
C  ARRAY ARGUMENTS
      REAL
     +   AB(*),YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   YEXTND
      INTEGER
     +   I,IPRT,ISN,N1,NFFT1,NFFT2
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LLAB(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,EISGE,ENFFT,FFT,IPRINT,REALTR
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AB(LAB)
C        THE VECTOR OF THE NF REAL AND IMAGINARY COMPONENTS OF THE
C        FOURIER COEFFICIENTS.
C     LOGICAL ERR01, ERR02, ERR03
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (TRUE) OR NOT (FALSE).
C     INTEGER I
C        AN INDEX VARIABLE.
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 IEXTND
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO
C        (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE
C        USED TO EXTEND THE SERIES.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER LAB
C        THE LENGTH OF THE VECTOR AB.
C     CHARACTER*1 LLAB(8), LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS.
C     INTEGER N1
C        THE VALUE N+1.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED.
C     INTEGER NFFT1
C        THE EFFECTIVE SERIES LENGTH ACTUALLY USED.
C     INTEGER NFFT2
C        THE EFFECTIVE LENGTH OF THE SERIES STORED AS A COMPLEX
C        VARIABLE.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     REAL YEXTND
C        THE VALUE USED TO EXTEND THE SERIES.
C     REAL YFFT(N)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'F',       'F',       'T',       'R',       ' ',       ' '/
      DATA
     +   LLAB(1),   LLAB(2),   LLAB(3),   LLAB(4),   LLAB(5),   LLAB(6)
     + /     'L',       'A',       'B',       ' ',       ' ',       ' '/
      DATA
     +   LLAB(7),   LLAB(8)
     + /     ' ',       ' '/
      DATA
     +     LN(1),     LN(2),     LN(3),     LN(4),     LN(5),     LN(6)
     + /     'N',       ' ',       ' ',       ' ',       ' ',       ' '/
      DATA
     +     LN(7),     LN(8)
     + /     ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN)
      IF (ERR01) GO TO 5
C
      CALL ENFFT(NMSUB, NFFT, 2, N, LAB, NFFT1, HEAD, ERR02, LN)
      NF = NFFT1/2
C
      CALL EISGE(NMSUB, LLAB, LAB, NFFT1, 9, HEAD, ERR03, LLAB)
C
      IF (ERR02 .OR. ERR03) GO TO 5
      GO TO 10
C
    5 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     COPY THE INPUT SERIES TO AB, EXTENDING APPROPRIATELY.
C
      YEXTND = 0.0E0
      IF (IEXTND .NE. 0) CALL AMEAN (YFFT, N, YEXTND)
C
      DO 20 I = 1, N
         AB(I) = YFFT(I)
   20 CONTINUE
C
      N1 = N+1
      DO 30 I = N1, NFFT1
         AB(I) = YEXTND
   30 CONTINUE
C
      NFFT2 = (NFFT1-2) / 2
      ISN = 2
C
      CALL FFT (AB(1), AB(2), NFFT2, NFFT2, NFFT2, ISN)
      CALL REALTR (AB(1), AB(2), NFFT2, ISN)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   53H       CALL FFTR (YFFT, N, NFFT, IEXTND, NF, AB, LAB))
      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
      REAL
     +   RSS,YSS
      LOGICAL
     +   EXACT
C
C  LOCAL SCALARS
      REAL
     +   FPLRS,RSSTST
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
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     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL RSSTST
C        THE VALUE FOR TESTING WHETHER THE RESIDUAL SUM OF SQUARES
C        IS ZERO (TO WITHIN MACHINE PRECISION).
C     REAL YSS
C        THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y.
C
      FPLRS = R1MACH(4)
C
C     TEST FOR EXACT FIT
C
      EXACT = .FALSE.
      RSSTST = RSS
      IF (YSS.GT.0.0E0) RSSTST = RSSTST / YSS
      RSSTST = SQRT(RSSTST)
      IF (RSSTST.LT.10.0E0*FPLRS) EXACT = .TRUE.
C
      RETURN
C
      END
*FITPT1
      SUBROUTINE FITPT1(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM,
     +   NNZW, WEIGHT, IPTOUT)
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  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IPTOUT,IXM,M,N,NNZW
      LOGICAL
     +   WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PV(N),RES(N),SDPV(N),SDRES(N),WT(N),XM(IXM,M),Y(N)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,IPRT,JCOL1,JCOLM,K,NMAX
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,OBSSUM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IERR
C        THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS HAVE
C        BEEN DETECTED.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED
C        IF IERR .NE. 0, ERRORS HAVE BEEN DETECTED.
C     INTEGER IPTOUT
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER JCOLM
C        THE LAST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED.
C     INTEGER JCOL1
C        THE FIRST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NMAX
C        THE MAXIMUM NUMBER OF ROWS TO BE PRINTED.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(N)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
      FPLM = R1MACH(2)
C
      CALL IPRINT(IPRT)
C
      WRITE (IPRT,1100)
C
      IF (WEIGHT) THEN
         WRITE (IPRT,1010)
      ELSE
         WRITE (IPRT,1000)
      END IF
      WRITE (IPRT, 1110)
C
C     TEST WHETHER COLUMN VECTOR XM(*, 1) = VECTOR 1.0E0
C
      DO 10 I=1,N
         IF (XM(I,1).NE.1.0E0) GO TO 20
   10 CONTINUE
      GO TO 30
C
C     NOT A UNIT VECTOR
C
   20 JCOL1 = 1
      JCOLM = MIN(M,3)
      GO TO 40
C
C     UNIT VECTOR
C
   30 JCOLM = MIN(M,4)
      JCOL1 = MIN(2,JCOLM)
   40 K = JCOLM - JCOL1 + 1
C
      NMAX = N
      IF ((IPTOUT.EQ.1) .AND. (N.GE.45)) NMAX = MIN(N,40)
C
C     PRINT OBSERVATION SUMMARY
C
      CALL OBSSUM(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM,
     +   WEIGHT, K, 1, NMAX, JCOL1, JCOLM)
C
      IF (NMAX.GE.N) GO TO 200
C
      DO 195 I = 1, 3
C
         GO TO (160, 170, 180), K
  160    WRITE (IPRT,1120)
         GO TO 190
  170    WRITE (IPRT,1130)
         GO TO 190
  180    WRITE (IPRT,1140)
C
  190    CONTINUE
         WRITE (IPRT, 1150)
         IF (WEIGHT) WRITE (IPRT, 1160)
C
  195 CONTINUE
C
C     PRINT LAST LINE OF OUTPUT
C
      CALL OBSSUM(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM,
     +   WEIGHT, K, N, N, JCOL1, JCOLM)
C
  200 CONTINUE
C
      IF ((NNZW.LT.N) .AND. (IERR.EQ.0)) WRITE (IPRT, 1060)
      IF ((NNZW.LT.N) .AND. (IERR.EQ.4)) WRITE (IPRT, 1070)
      IF ((NNZW.EQ.N) .AND. (IERR.EQ.4)) WRITE (IPRT, 1080)
      IF ((IERR.GT.0) .AND. (IERR.NE.4)) WRITE (IPRT, 1090)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/53X, 9HDEPENDENT, 7X, 9HPREDICTED, 5X, 12H STD DEV OF ,
     +   24X, 4HSTD /
     +   2X, 3HROW, 13X, 16HPREDICTOR VALUES, 20X, 8HVARIABLE, 8X,
     +   6H VALUE, 8X, 12HPRED VALUE  , 6X, 9HRESIDUAL , 8X, 3HRES)
 1010 FORMAT (/53X, 9HDEPENDENT, 7X, 9HPREDICTED, 5X, 12H STD DEV OF ,
     +   24X, 4HSTD /
     +   2X, 3HROW, 13X, 16HPREDICTOR VALUES, 20X, 8HVARIABLE, 8X,
     +   6H VALUE, 8X, 12HPRED VALUE  , 6X, 9HRESIDUAL , 8X, 3HRES,
     +   4X, 6HWEIGHT)
 1060 FORMAT (// 37H *  NC  -  VALUE NOT COMPUTED BECAUSE,
     +   20H THE WEIGHT IS ZERO.)
 1070 FORMAT (// 44H *  NC  -  VALUE NOT COMPUTED BECAUSE EITHER,
     +   53H THE WEIGHT OR THE STANDARD DEVIATION OF THE RESIDUAL,
     +   9H IS ZERO.)
 1080 FORMAT (// 37H *  NC  -  VALUE NOT COMPUTED BECAUSE,
     +   48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.)
 1090 FORMAT (// 29H *  NC  -  VALUE NOT COMPUTED,
     +   54H BECAUSE CONVERGENCE PROBLEMS PREVENTED THE COVARIANCE,
     +   28H MATRIX FROM BEING COMPUTED.)
 1100 FORMAT (//31H RESULTS FROM LEAST SQUARES FIT/ 1X, 31('-'))
 1110 FORMAT (' ')
 1120 FORMAT (4X, '.', 25X, '.')
 1130 FORMAT (4X, '.', 3X, 2(14X, '.'))
 1140 FORMAT (4X, '.', 10X, '.', 2(14X, '.'))
 1150 FORMAT ('+', 49X, 11X, '.', 3(15X, '.'), 11X, '.')
 1160 FORMAT ('+', 130X, '.')
      END
*FITPT2
      SUBROUTINE FITPT2 (SDRES, PV, WT, N, NNZW, WEIGHT, RES, RSS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE, ADAPTED FROM OMNITAB II, PRINTS
C     THE FOUR STANDARDIZED RESIDUAL PLOTS.
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
      REAL
     +   RSS
      INTEGER
     +   N,NNZW
      LOGICAL
     +   WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PV(N),RES(N),SDRES(N),WT(N)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ANNZW,DOT,FAC1,FAC2,FPLM,GAMMA,PI,PVDIV,PVMAX,PVMID,PVMIN,
     +   RATIO,ROWDIV,ROWMAX,ROWMID,ROWMIN,W,XDIV,XMAX,XMIN,YLABEL,
     +   YMAX,YMIN
      INTEGER
     +   I,I1,I2,IDOT,IFIRST,IMID,IPLOT,IPRB,IPRT,IPV,IROW,IX,K,L,
     +   NCOL,NCOLP1,NCOLPL,NCOLT2,NDOT,NROW
      CHARACTER
     +   IBLANK*1,IMINUS*1,IPLUS*1,ISTAR*1
C
C  LOCAL ARRAYS
      CHARACTER
     +   LINE(102)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      LOGICAL
     +   MVCHK
      EXTERNAL R1MACH,MVCHK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT,MAX,MIN,MOD
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ANNZW
C        THE NUMBER OF NONZERO WEIGHTS, USED IN COMPUTING
C        THE NORMAL PROBABILITY PLOT.
C     REAL DOT
C        ...
C     REAL FAC1, FAC2
C        FACTORS USED IN COMPUTING THE NORMAL PROBABILITY PLOT.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL GAMMA
C        A VALUE USED IN COMPUTING THE NORMAL PROBABILITY PLOT.
C     INTEGER I
C        AN INDEX VARIABLE.
C     CHARACTER*1 IBLANK
C        THE VALUE OF THE CHARACTER -BLANK-.
C     INTEGER IERR
C        THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS HAVE
C        BEEN DETECTED.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED
C        IF IERR .NE. 0, ERRORS HAVE BEEN DETECTED.
C     INTEGER IFIRST
C        THE FIRST ROW OF THE VARIABLES TO BE PLOTTED.
C     INTEGER IMID
C        THE MIDPOINT OF THE FIRST PLOT OF THE SECOND SET
C     CHARACTER*1 IMINUS
C        THE CHARACTER MINUS.
C     INTEGER IPLOT
C        AN INDICATOR VARIABLE DESIGNATING WHETHER THE FIRST OR
C        SECOND SET OF TWO PLOTS ARE BEING PRINTED.
C     CHARACTER*1 IPLUS
C        THE CHARACTER PLUS.
C     INTEGER IPRB
C        THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE
C        PROBABILITY PLOT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IPV
C        THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE PLOT
C        VERSUS PREDICTED VALUE.
C     INTEGER IROW
C        THE ROW OF THE VARIABLES BEING PLOTTED.
C     CHARACTER*1 ISTAR
C        THE CHARACTER STAR.
C     INTEGER IX
C        THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE PLOTS
C        VERSUS THE INDEPENDENT VARIABLE.
C     INTEGER I1, I2
C        ...
C     INTEGER K, L
C        INDEX VARIABLES.
C     CHARACTER*1 LINE(102)
C        THE SYMBOLS (BLANKS AND CHARACTERS) FOR A GIVEN LINE
C        OF THE PLOT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN EACH COLUMN OF DATA.
C     INTEGER NCOL, NCOLPL, NCOLP1, NCOLT2
C        THE NUMBER OF COLUMNS IN THE PLOT, NCOL+L, NCOL+1,
C        AND NCOL * 2.
C     INTEGER NDOT
C        ...
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NROW
C        THE NUMBER OF COLUMNS IN THE PLOT.
C     REAL PI
C        THE VALUE OF PI.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT COEFFICIENT ESTIMATES
C     REAL PVDIV
C        THE VALUE OF A DIVISION ALONG THE -PREDICTED VALUE- AXIS.
C     REAL PVMAX
C        THE LARGEST VALUE IN THE VECTOR PV.
C     REAL PVMID
C        THE MIDPOINT OF THE RANGE OF VALUES IN THE VECTOR PV.
C     REAL PVMIN
C        THE SMALLEST VALUE IN THE VECTOR PV.
C     REAL RATIO
C        A VALUE USED TO PRODUCE THE NORMAL PROBABILITY PLOT.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL ROWDIV
C        THE VALUE OF A DIVISION ALONG THE -ROW- AXIS.
C     REAL ROWMAX
C        THE LARGEST ROW VALUE.
C     REAL ROWMID
C        THE MIDPOINT OF THE RANGE OF THE ROWS PLOTTED.
C     REAL ROWMIN
C        THE SMALLEST ROW VALUE PLOTTED.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL W
C        THE VALUE OF THE WEIGHT FOR THE CURRENT VALUE BEING PLOTTED.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(N)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XDIV
C        THE VALUE OF A DIVISION ALONG THE X AXIS.
C     REAL XMAX
C        THE LARGEST VALUE ALONG THE X AXIS.
C     REAL XMIN
C        THE SMALLEST VALUE ALONG THE X AXIS.
C     REAL YLABEL
C        THE LABEL TO BE PRINTED ALONG THE Y AXIS.
C     REAL YMAX
C        THE LARGEST VALUE ALONG THE Y AXIS
C     REAL YMIN
C        THE SMALLEST VALUE ALONG THE Y AXIS.
C
      DATA IPLUS/'+'/, IMINUS/'-'/, ISTAR/'*'/, IBLANK/' '/
C
      CALL IPRINT(IPRT)
C
      FPLM = R1MACH(2)
C
C     CHECK FOR INSUFFICIENT POINTS TO PLOT
C
      IF (IERR.EQ.4) THEN
         DO 1 I = 1, N
            IF (SDRES(I).NE.FPLM) GO TO 5
    1    CONTINUE
         WRITE (IPRT, 1090)
         RETURN
      END IF
    5 CONTINUE
C
C     INITIALIZE VARIABLES FOR PROBABILITY PLOT
C
      CALL GETPI(PI)
      GAMMA = PI/8.0E0
      ANNZW = NNZW
      FAC1 = 1.0E0 / (ANNZW - 2.0E0*GAMMA + 1.0E0)
      FAC2 = 10.0E0
C
C     INITIALIZE THE PLOT SIZE (IN PLOT UNITS)
C
      NROW = 26
      NCOL = 51
      NCOLP1 = NCOL + 1
      NCOLT2 = 2*NCOL
      IMID = (NCOL-1)/2
C
C     FIND THE FIRST ROW OF OBSERVATIONS WITH NONZERO WEIGHTS
C
      IFIRST = 1
      IF (.NOT. WEIGHT) GO TO 20
      DO 10 I=1,N
         IF (WT(I).LE.0.0E0) GO TO 10
         IFIRST = I
         GO TO 20
   10 CONTINUE
C
C     BEGIN COMPUTATIONS FOR FIRST SET OF PLOTS
C
   20 IPLOT = 1
C
C     SET X AXIS LIMITS FOR STANDARDIZED RESIDUAL VS ROW PLOT,
C     AND STANDARDIZED RESIDUALS VS PREDICTED VALUES PLOT.
C
      ROWMIN = IFIRST
      PVMIN = PV(IFIRST)
      PVMAX = PV(IFIRST)
      ROWMAX = IFIRST
      DO 30 I=IFIRST,N
         W = 1.0E0
         IF (WEIGHT) W = WT(I)
         IF (W.GT.0.0E0) THEN
            ROWMAX = I
            IF (PV(I).LT.PVMIN) PVMIN = PV(I)
            IF (PV(I).GT.PVMAX) PVMAX = PV(I)
         END IF
   30 CONTINUE
C
      IF (PVMIN.LT.PVMAX) GO TO 35
         IF (PVMIN.EQ.0.0E0) GO TO 33
            PVMIN = PVMIN - PVMIN/2.0E0
            PVMAX = PVMAX + PVMAX/2.0E0
         GO TO 35
   33    CONTINUE
            PVMIN = -0.5E0
            PVMAX = 0.5E0
   35 CONTINUE
C
      ROWMID = (ROWMAX+ROWMIN)/2.0E0
      ROWDIV = (ROWMAX-ROWMIN)/(NCOL-1)
      PVMID = (PVMAX+PVMIN)/2.0E0
      PVDIV = (PVMAX-PVMIN)/(NCOL-1)
C
C     PRINT TITLES FOR FIRST PLOTS
C
      WRITE (IPRT,1000)
      GO TO 90
C
C     BEGIN COMPUTATIONS FOR SECOND SET OF PLOTS
C
   40 IPLOT = 2
C
C     SET AXIS LIMITS FOR THE STANDARDIZED RESIDUALS VS
C     STANDARDIZED RESIDUALS LAGED BY ONE AND FOR PROBABILITY PLOT
C
      XMIN = -3.75E0
      XMAX = 3.75E0
      XDIV = (XMAX-XMIN)/(NCOL-1)
C
C     PRINT TITLES FOR SECOND PLOTS
C
      WRITE (IPRT,1050)
C
C     WRITE FIRST LINE OF PLOTS
C
   90 CONTINUE
C
C     PRINT PLOTS, ONE LINE AT A TIME
C
      YLABEL = 3.75E0
      YMAX = FPLM
      YMIN = 4.05E0
      DO 160 K=1,NROW
         YMIN = YMIN - 0.3E0
         IF (-3.70E0.GE.YMIN) YMIN = -FPLM
         DO 100 L=1,NCOL
            NCOLPL = L + NCOL
            LINE(L) = IBLANK
            LINE(NCOLPL) = IBLANK
            IF ((K.NE.1) .AND. (K.NE.NROW)) GO TO 100
               LINE(L) = IMINUS
               LINE(NCOLPL) = IMINUS
               IF ((MOD(L,10).NE.1) .AND. (L.NE.1+NCOL/2)) GO TO 100
                  LINE(L) = IPLUS
                  LINE(NCOLPL) = IPLUS
  100    CONTINUE
         DO 110 I=1,N
            IF (WEIGHT) THEN
               W = WT(I)
            ELSE
               W = 1.0E0
            END IF
            IF ((W.NE.0.0E0) .AND. (.NOT.MVCHK(SDRES(I),FPLM))) THEN
               IF ((SDRES(I).GT.YMIN) .AND. (SDRES(I).LE.YMAX)) THEN
                  IF (IPLOT.EQ.1) THEN
C
C     SET PLOT LINE FOR FIRST SET OF PLOTS
C
                     IROW = INT(((I-ROWMIN)/ROWDIV)+1.5E0)
                     LINE(IROW) = ISTAR
                     IPV = INT((PV(I)-PVMIN)/PVDIV+1.5E0) + NCOL
                     LINE(IPV) = ISTAR
                  ELSE
C
C     SET PLOT LINE FOR PROBABILITY PLOT
C
                     RATIO = (ANNZW-GAMMA) * FAC1
                     IPRB = INT(4.91E0*(RATIO**0.14E0-
     +                         (1.0E0-RATIO)**0.14E0)*FAC2) + 77
                     IF (IPRB.LE.NCOL) IPRB = NCOL+1
                     IF (IPRB.GE.103) IPRB = 102
                     LINE(IPRB) = ISTAR
                     ANNZW = ANNZW - 1.0E0
                     IF ((ANNZW.LT.2.0E0) .AND. (NNZW.LE.10)) THEN
                        GAMMA = 1.0E0/3.0E0
                     END IF
                  END IF
               END IF
            END IF
  110    CONTINUE
C
C     SET PLOT LINE FOR CORRELATION PLOT
C
         IF (IPLOT.EQ.2) THEN
            IF (K.LE.N-1) THEN
              DOT = 0.0E0
              IF (WEIGHT) THEN
                NDOT = 0
                DO 120 IDOT = 1, N-K
                  IF ((WT(IDOT).GT.0.0E0) .AND.
     +                (WT(IDOT+K).GT.0.0E0)) THEN
                    NDOT = NDOT + 1
                    DOT = DOT + RES(IDOT)*RES(IDOT+K)
                  END IF
  120           CONTINUE
                IF (NDOT.GE.1) THEN
                   DOT = DOT * (N-K) / NDOT
                END IF
              ELSE
                DO 130 IDOT = 1, N-K
                  DOT = DOT + RES(IDOT)*RES(IDOT+K)
  130           CONTINUE
              END IF
              IX = INT(IMID*DOT/RSS) + IMID + 1
              I1 = MIN(IX,IMID+1)
              I2 = MAX(IX,IMID+1)
              DO 140 IX=I1,I2
                LINE(IX) = ISTAR
  140         CONTINUE
            END IF
         END IF
         IF (MOD(K,5).EQ.1) THEN
            IF (IPLOT.EQ.1) THEN
               WRITE (IPRT,2020) YLABEL, (LINE(L),L=1,NCOL), YLABEL,
     +         (LINE(L),L=NCOLP1,NCOLT2)
            ELSE
               WRITE (IPRT,1020) K, (LINE(L),L=1,NCOL), YLABEL,
     +         (LINE(L),L=NCOLP1,NCOLT2)
            END IF
            YLABEL = YLABEL - 1.5
         ELSE
            WRITE (IPRT,1030) (LINE(L),L=1,102)
         END IF
         YMAX = YMIN
  160 CONTINUE
C
C     PRINT BOTTOM LINE OF GRAPHS
C
      IF (IPLOT.EQ.1) THEN
C
C     PRINT X AXIS LABELS FOR FIRST SET OF PLOTS
C
         WRITE (IPRT,1040) ROWMIN, ROWMID, ROWMAX, PVMIN, PVMID, PVMAX
         GO TO 40
      ELSE
C
C     PRINT X AXIS LABELS FOR SECOND SET OF PLOTS
C
         WRITE (IPRT,1070)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/20X, 23H STD RES VS ROW NUMBER , 35X,
     +   29H STD RES VS PREDICTED VALUES )
C1010 FORMAT (7X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1), '+',
C    *   10X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1), '+')
 1020 FORMAT (1X, I5, '+', 51A1, '+', 3X, F5.2, '+', 51A1, '+')
 1030 FORMAT (6X, '-', 51A1, '-', 8X, '-', 51A1, '-')
 1040 FORMAT (1X, F8.1, 17X, F8.1, 17X, F8.1, 4X, G11.4, 14X, G11.4,
     +   10X, G11.4)
 1050 FORMAT (/13X, 'AUTOCORRELATION FUNCTION OF RESIDUALS',
     +   23X, 36H NORMAL PROBABILITY PLOT OF STD RES )
C1060 FORMAT ('+', F5.2, '+', 51A1, '+', 3X, F5.2, '+', 51A1, '+')
 1070 FORMAT (4X, 5H-1.00, 22X, 3H0.0, 21X, 4H1.00, 5X, 4H-2.5, 23X,
     +   3H0.0, 22X, 3H2.5)
C1080 FORMAT ('+', 6X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1),
C    *   '+', 10X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1), '+')
 1090 FORMAT (// 1X, 13('*')/ 1X, 13H*  WARNING  */ 1X, 13('*')//
     +   54H THE STANDARDIZED RESIDUAL PLOTS HAVE BEEN SUPPRESSED.,
     +   45H  NONE OF THE STANDARDIZED RESIDUALS COULD BE,
     +   10H COMPUTED,/
     +   50H BECAUSE FOR EACH OBSERVATION EITHER THE WEIGHT OR,
     +   48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.)
 2020 FORMAT (1X, F5.2, '+', 51A1, '+', 3X, F5.2, '+', 51A1, '+')
      END
*FITSXP
      SUBROUTINE FITSXP(PAR, PV, SDPV, RES, SDRES, VCV, N, NPAR, IVCV,
     +    RSD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     GENERATES REPORTS FOR LEAST SQUARES EXERCISER RETURNED STORAGE
C
C     WRITTEN BY  -  LINDA L. MITCHELL
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCV(IVCV,NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LSTVEC,MATPRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        INDEX VARIABLE
C     INTEGER IPRT
C        LOGICAL OUTPUT UNIT
C     INTEGER IVCV
C        ACTUAL FIRST DIMENSION OF VCV
C     INTEGER N
C        NUMBER OF OBSERVATIONS
C     INTEGER NPAR
C        NUMBER OF PARAMETERS
C     REAL PAR(NPAR)
C        THE ESTIMATED PARAMETERS.
C     REAL PV(N)
C        PREDICTED VALUES
C     REAL RES(N)
C        RESIDUALS
C     REAL RSD
C        RESIDUAL STANDARD DEVIATION
C     REAL SDPV(N)
C        STANDARD DEVIATION OF PREDICTED VALUES
C     REAL SDRES(N)
C        STANDARD DEVIATION OF RESIDUALS
C     REAL VCV(IVCV,NPAR)
C        VARIANCE COVARANCE MATRIX
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      WRITE (IPRT,1002)
      CALL LSTVEC(NPAR, PAR)
      WRITE (IPRT,1001)
      DO 10 I=1,N
         WRITE (IPRT,1010) PV(I), SDPV(I), RES(I), SDRES(I)
   10 CONTINUE
      WRITE (IPRT,1020)
      CALL MATPRT(VCV, VCV, NPAR, IPRT, 1, 1, IVCV)
      WRITE (IPRT,1030) RSD
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(//40H RETURNED RESULTS FROM LEAST SQUARES FIT/ 1X, 39('-'))
 1001 FORMAT (//7X, 2HPV, 13X, 4HSDPV, 12X, 3HRES,12X, 5HSDRES)
 1002 FORMAT (//20H PARAMETERS FROM FIT)
 1010 FORMAT (1X, G14.7, 2X, G14.7, 2X, G14.7, 2X, G14.7)
 1020 FORMAT (//27H VARIANCE COVARIANCE MATRIX)
 1030 FORMAT (//6H RSD =, G14.7)
      END
*FITXSP
      SUBROUTINE FITXSP(PAR, PV, SDPV, RES, SDRES, VCV, N, NPAR, IVCV,
     +   NNZW, NPARE, RSD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     GENERATES REPORTS FOR LEAST SQUARES EXERCISER RETURNED STORAGE
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,N,NNZW,NPAR,NPARE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCV(IVCV,NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,MATPRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        INDEX VARIABLE
C     INTEGER IPRT
C        LOGICAL OUTPUT UNIT
C     INTEGER IVCV
C        ACTUAL FIRST DIMENSION OF VCV
C     INTEGER N
C        NUMBER OF OBSERVATIONS
C     INTEGER NPAR
C        NUMBER OF PARAMETERS
C     INTEGER NPARE
C        NUMBER OF PARAMETERS ESTIMATED BY ROUTINE.
C     INTEGER NNZW
C        NUMBER OF NONZERO WEIGHTS.
C     REAL PAR(NPAR)
C        THE ESTIMATED PARAMETERS.
C     REAL PV(N)
C        PREDICTED VALUES
C     REAL RES(N)
C        RESIDUALS
C     REAL RSD
C        RESIDUAL STANDARD DEVIATION
C     REAL SDPV(N)
C        STANDARD DEVIATION OF PREDICTED VALUES
C     REAL SDRES(N)
C        STANDARDIZED RESIDUALS.
C     REAL VCV(IVCV,NPAR)
C        VARIANCE COVARANCE MATRIX
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      DO 10 I=1,N
         IF (I.LE.NPAR) THEN
            WRITE (IPRT,1010) I,PAR(I),RES(I),PV(I),SDPV(I),SDRES(I)
         ELSE
            WRITE (IPRT,1070) I,RES(I),PV(I),SDPV(I),SDRES(I)
         END IF
   10 CONTINUE
      WRITE (IPRT,1030)
      CALL MATPRT(VCV, VCV, IVCV, IPRT, 1, 1, IVCV)
      WRITE (IPRT,1060) RSD
      WRITE (IPRT,1040) NNZW
      WRITE (IPRT,1050) NPARE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/12X, 3HPAR, 12X, 3HRES, 12X, 2HPV, 13X, 4HSDPV, 12X,
     +   5HSDRES/)
 1010 FORMAT (1X, I5, G14.7, 2X, 4(G14.7, 2X))
 1030 FORMAT (/27H VARIANCE COVARIANCE MATRIX)
 1040 FORMAT (8H NNZW = , I5)
 1050 FORMAT (9H NPARE = , I5)
 1060 FORMAT (/7H RSD = , G14.7)
 1070 FORMAT (1X, I5, 16X, 4(G14.7, 2X))
      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
      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
*FLTAR
      SUBROUTINE FLTAR (Y, N, IAR, PHI, YF, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE FILTERS THE INPUT SERIES Y USING THE IAR TERMS
C     OF THE AUTOREGRESSIVE FILTER PHI, COPYING THE FILTERED SERIES
C     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
     +   IAR,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   PHI(*),Y(*),YF(*)
C
C  LOCAL SCALARS
      REAL
     +   TEMP
      INTEGER
     +   I,I1,J,K
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IAR
C        THE NUMBER OF FILTER TERMS.
C     INTEGER I1, J, K
C        INDEXING VARIABLES.
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     REAL PHI(IAR)
C        THE ARRAY IN WHICH THE FILTER COEFFICIENTS ARE STORED.
C     REAL TEMP
C        A TEMPORARY STORAGE LOCATION.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
      DO 10 I = 1, N
         YF(I) = Y(I)
   10 CONTINUE
C
      NYF = N - IAR
C
      DO 30 I = 1, NYF
         K = I + IAR
         TEMP = YF(K)
         DO 20 J = 1, IAR
            K = K - 1
            TEMP = TEMP - PHI(J) * YF(K)
   20    CONTINUE
         YF(I) = TEMP
   30 CONTINUE
C
      I1 = NYF + 1
C
      DO 40 I = I1, N
         YF(I) = 0.0E0
   40 CONTINUE
      RETURN
      END
*FLTARM
      SUBROUTINE FLTARM (Y, YMISS, N, IAR, PHI, YF, YFMISS, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE FILTERS THE INPUT SERIES Y, WHICH CONTAINS MISSING
C     DATA, USING THE IAR TERMS OF THE AUTOREGRESSIVE FILTER PHI,
C     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
      REAL
     +   YFMISS,YMISS
      INTEGER
     +   IAR,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   PHI(*),Y(*),YF(*)
C
C  LOCAL SCALARS
      REAL
     +   FPLM,TEMP
      INTEGER
     +   I,I1,J,K
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      LOGICAL
     +   MVCHK
      EXTERNAL R1MACH,MVCHK
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IAR
C        THE NUMBER OF FILTER TERMS.
C     INTEGER I1, J, K
C        INDEXING VARIABLES.
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     REAL PHI(IAR)
C        THE ARRAY IN WHICH THE FILTER COEFFICIENTS ARE STORED.
C     REAL TEMP
C        A TEMPORARY STORAGE LOCATION.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C     REAL YFMISS
C        THE MISSING VALUE CODE USED IN THE FILTERED SERIES TO
C        INDICATE THE VALUE COULD NOT BE COMPUTED DUE TO MISSING DATA.
C     REAL YMISS
C        THE MISSING VALUE CODE USED IN THE INPUT SERIES TO INDICATE
C        AN OBSERVATION IS MISSING.
C
      FPLM = R1MACH(2)
C
      YFMISS = FPLM
C
      DO 10 I = 1, N
         YF(I) = Y(I)
   10 CONTINUE
C
      NYF = N - IAR
C
      DO 50 I = 1, NYF
         TEMP = YFMISS
         K = I + IAR
         IF (MVCHK(YF(K), YMISS)) GO TO 40
         TEMP = YF(K)
         DO 30 J = 1, IAR
            K = K - 1
            IF (.NOT. MVCHK(YF(K), YMISS)) GO TO 20
            TEMP = YFMISS
            GO TO 40
   20       CONTINUE
            TEMP = TEMP - PHI(J) * YF(K)
   30    CONTINUE
   40    YF(I) = TEMP
   50 CONTINUE
C
      I1 = NYF + 1
C
      DO 60 I = I1, N
         YF(I) = 0.0E0
   60 CONTINUE
      RETURN
      END
*FLTMA
      SUBROUTINE FLTMA (Y, N, K, HMA, 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
      REAL
     +   HMA
      INTEGER
     +   K,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(N),YF(N)
C
C  LOCAL SCALARS
      REAL
     +   SUM
      INTEGER
     +   I,I1,II,J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL HMA
C        THE VALUE OF EACH OF THE SIMPLE MOVING AVERAGE LINEAR FILTER
C        COEFFICIENTS.
C     INTEGER I, II, I1, J
C        INDEXING VARIABLES.
C     INTEGER K
C        THE NUMBER OF FILTER TERMS.
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     REAL SUM
C        A TEMPORARY LOCATION USED IN COMPUTING THE FILTERED SERIES.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
      DO 10 I = 1, N
         YF(I) = Y(I)
   10 CONTINUE
C
      NYF = N - (K - 1)
C
      DO 30 I = 1, NYF
         II = I - 1
         SUM = 0.0E0
         DO 20 J = 1, K
            II = II + 1
            SUM = SUM + HMA*YF(II)
   20    CONTINUE
         YF(I) = SUM
   30 CONTINUE
C
      I1 = NYF + 1
C
      DO 40 I = I1, N
         YF(I) = 0.0E0
   40 CONTINUE
C
      RETURN
      END
*FLTMD
      SUBROUTINE FLTMD (X, Y, N, KMD, SYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE APPLIES ONE MODIFIED DANIEL FILTERS TO A SYMMETRIC
C     SERIES.  THIS ROUTINE IS ADAPTED FROM BLOOMFIELDS ROUTINE MODDAN.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   SYM
      INTEGER
     +   KMD,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N),Y(N)
C
C  LOCAL SCALARS
      REAL
     +   CON
      INTEGER
     +   I,J,KUSED,LIM
C
C  EXTERNAL FUNCTIONS
      REAL
     +   EXTEND
      EXTERNAL EXTEND
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CON
C        A FACTOR USED IN THE COMPUTATIONS.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER J
C        AN INDEXING VARIABLE.
C     INTEGER KMD
C        THE INPUT FILTER LENGTH.
C     INTEGER KUSED
C        THE FILTER LENGTH ACTUALLY USED.
C     INTEGER LIM
C        A LOOP LIMIT.
C     INTEGER N
C        THE NUMBER OF POINTS IN THE SERIES TO BE FILTERED.
C     REAL SYM
C        AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SERIES
C        IS SYMMETRIC (SYM = 1.0E0) OR NOT (SYM = -1.0E0).
C     REAL X(N)
C        ON INPUT, THE SERIES TO BE FILTERED.  ON OUTPUT, THE
C        SMOOTHED SERIES.
C     REAL Y(N)
C        ON INPUT, A WORK VECTOR.  ON OUTPUT, THE INPUT SERIES X.
C
C
      DO 10 I = 1, N
         Y(I) = X(I)
   10 CONTINUE
C
      IF (KMD .LE. 0) RETURN
C
      KUSED = KMD + MOD(KMD,2)
      IF (KUSED .GT. N) KUSED = KUSED - 2
C
      LIM = KUSED-1
      CON = 1.0E0 / (2*KUSED)
      DO 40 I = 1, N
         X(I) = Y(I)
         IF (LIM .EQ. 0) GO TO 30
         DO 20 J = 1, LIM
            X(I) = X(I) + EXTEND(Y, I-J, N, SYM)
     +         + EXTEND(Y, I+J, N, SYM)
   20    CONTINUE
   30    X(I) = (X(I) + (EXTEND(Y, I-KUSED, N, SYM)
     +      + EXTEND(Y, I+KUSED, N, SYM)) * 0.5E0) * CON
   40 CONTINUE
C
      RETURN
C
      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
      REAL
     +   H(K),Y(N),YF(N)
C
C  LOCAL SCALARS
      REAL
     +   TEMP
      INTEGER
     +   I,I1,IHM,IHP,IKMID,IM,IP,J,KHALF,KMID
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL TEMP
C        A TEMPORY STORAGE LOCATION.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
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.0E0
   40 CONTINUE
      RETURN
      END
*GAMI
      REAL FUNCTION GAMI (A, X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C EVALUATE THE INCOMPLETE GAMMA FUNCTION DEFINED BY
C
C GAMI = INTEGRAL FROM T = 0 TO X OF EXP(-T) * T**(A-1.0) .
C
C GAMI IS EVALUATED FOR POSITIVE VALUES OF A AND NON-NEGATIVE VALUES
C OF X.  A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR
C WHEN GAMI IS VERY LARGE OR VERY SMALL, BECAUSE LOGARITHMIC VARIABLES
C ARE USED.
C
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL A,X
C
C  LOCAL SCALARS
      REAL FACTOR
C
C  EXTERNAL FUNCTIONS
      REAL ALNGAM,GAMIT,R1MACH
      EXTERNAL ALNGAM,GAMIT,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP,LOG
C
      IF (A.LE.0.0) CALL XERROR ('GAMI    A MUST BE GT ZERO', 25, 1, 2)
      IF (X.LT.0.0) CALL XERROR ('GAMI    X MUST BE GE ZERO', 25, 2, 2)
C
      GAMI = 0.0
      IF (X.EQ.0.0) RETURN
C
C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW.
C
      FACTOR = ALNGAM(A) + A*LOG(X)
      IF (FACTOR.GT.LOG(R1MACH(2))) THEN
         GAMI = R1MACH(2)
      ELSE
         GAMI = EXP(FACTOR) * GAMIT(A,X)
      END IF
C
      RETURN
      END
*GAMIT
      REAL FUNCTION GAMIT (A, X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C EVALUATE TRICOMI-S INCOMPLETE GAMMA FUNCTION DEFINED BY
C
C GAMIT = X**(-A)/GAMMA(A) * INTEGRAL T = 0 TO X OF EXP(-T) * T**(A-1.)
C
C AND ANALYTIC CONTINUATION FOR A .LE. 0.0.  GAMMA(X) IS THE COMPLETE
C GAMMA FUNCTION OF X.  GAMIT IS EVALUATED FOR ARBITRARY REAL VALUES OF
C A AND FOR NON-NEGATIVE VALUES OF X (EVEN THOUGH GAMIT IS DEFINED FOR
C X .LT. 0.0), EXCEPT THAT FOR X = 0 AND A .LE. 0.0, GAMIT IS INFINITE,
C A FATAL ERROR.
C
C      A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR WHEN
C GAMIT IS VERY LARGE OR VERY SMALL IN ABSOLUTE VALUE, BECAUSE LOG-
C ARITHMIC VARIABLES ARE USED.  ALSO, IF THE PARAMETER A IS VERY CLOSE
C TO A NEGATIVE INTEGER (BUT NOT A NEGATIVE INTEGER), THERE IS A LOSS
C OF ACCURACY, WHICH IS REPORTED IF THE RESULT IS LESS THAN HALF
C MACHINE PRECISION.
C
C REF. -- W. GAUTSCHI, AN EVALUATION PROCEDURE FOR INCOMPLETE GAMMA
C FUNCTIONS, ACM TRANS. MATH. SOFTWARE.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL A,X
C
C  LOCAL SCALARS
      REAL AEPS,AINTA,ALGAP1,ALNEPS,ALNG,ALX,BOT,H,SGA,SGNGAM,SQEPS,T
C
C  EXTERNAL FUNCTIONS
      REAL ALNGAM,GAMR,R1MACH,R9GMIT,R9LGIC,R9LGIT
      EXTERNAL ALNGAM,GAMR,R1MACH,R9GMIT,R9LGIC,R9LGIT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ALGAMS,XERCLR,XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,AINT,EXP,LOG,SIGN,SQRT
C
      DATA ALNEPS, SQEPS, BOT / 3*0.0 /
C
      IF (ALNEPS.NE.0.0) GO TO 10
      ALNEPS = -LOG(R1MACH(3))
      SQEPS = SQRT(R1MACH(4))
      BOT = LOG(R1MACH(1))
C
 10   IF (X.LT.0.0) CALL XERROR ('GAMIT   X IS NEGATIVE', 21, 2, 2)
C
      IF (X.NE.0.0) ALX = LOG(X)
      SGA = 1.0
      IF (A.NE.0.0) SGA = SIGN (1.0, A)
      AINTA = AINT (A+0.5*SGA)
      AEPS = A - AINTA
C
      IF (X.GT.0.0) GO TO 20
      GAMIT = 0.0
      IF (AINTA.GT.0.0 .OR. AEPS.NE.0.0) GAMIT = GAMR(A+1.0)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 40
      IF (A.GE.(-0.5) .OR. AEPS.NE.0.0) CALL ALGAMS (A+1.0, ALGAP1,
     1  SGNGAM)
      GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX)
      RETURN
C
 40   IF (A.LT.X) GO TO 50
      T = R9LGIT (A, X, ALNGAM(A+1.0))
      IF (T.LT.BOT) CALL XERCLR
      GAMIT = EXP(T)
      RETURN
C
 50   ALNG = R9LGIC (A, X, ALX)
C
C EVALUATE GAMIT IN TERMS OF LOG(GAMIC(A,X))
C
      H = 1.0
      IF (AEPS.EQ.0.0 .AND. AINTA.LE.0.0) GO TO 60
      CALL ALGAMS (A+1.0, ALGAP1, SGNGAM)
      T = LOG(ABS(A)) + ALNG - ALGAP1
      IF (T.GT.ALNEPS) GO TO 70
      IF (T.GT.(-ALNEPS)) H = 1.0 - SGA*SGNGAM*EXP(T)
      IF (ABS(H).GT.SQEPS) GO TO 60
      CALL XERCLR
      CALL XERROR ('GAMIT   RESULT LT HALF PRECISION', 32, 1, 1)
C
 60   T = -A*ALX + LOG(ABS(H))
      IF (T.LT.BOT) CALL XERCLR
      GAMIT = SIGN (EXP(T), H)
      RETURN
C
 70   T = T - A*ALX
      IF (T.LT.BOT) CALL XERCLR
      GAMIT = -SGA*SGNGAM*EXP(T)
      RETURN
C
      END
*GAMLIM
      SUBROUTINE GAMLIM (XMIN, XMAX)
C APRIL 1977 VERSION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C CALCULATE THE MINIMUM AND MAXIMUM LEGAL BOUNDS FOR X IN GAMMA(X).
C XMIN AND XMAX ARE NOT THE ONLY BOUNDS, BUT THEY ARE THE ONLY NON-
C TRIVIAL ONES TO CALCULATE.
C
C             OUTPUT ARGUMENTS --
C XMIN   MINIMUM LEGAL VALUE OF X IN GAMMA(X).  ANY SMALLER VALUE OF
C        X MIGHT RESULT IN UNDERFLOW.
C XMAX   MAXIMUM LEGAL VALUE OF X IN GAMMA(X).  ANY LARGER VALUE WILL
C        CAUSE OVERFLOW.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL XMAX,XMIN
C
C  LOCAL SCALARS
      REAL ALNBIG,ALNSML,XLN,XOLD
      INTEGER I
C
C  EXTERNAL FUNCTIONS
      REAL R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG,MAX
C
      ALNSML = LOG(R1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = LOG(XMIN)
        XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML)
     1    / (XMIN*XLN + 0.5)
        IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20
 10   CONTINUE
      CALL XERROR ('GAMLIM  UNABLE TO FIND XMIN', 27, 1, 2)
C
 20   XMIN = -XMIN + 0.01
C
      ALNBIG = LOG(R1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = LOG(XMAX)
        XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG)
     1    / (XMAX*XLN - 0.5)
        IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40
 30   CONTINUE
      CALL XERROR ('GAMLIM  UNABLE TO FIND XMAX', 27, 2, 2)
C
 40   XMAX = XMAX - 0.01
      XMIN = MAX (XMIN, -XMAX+1.)
C
      RETURN
      END
*GAMMA
      REAL FUNCTION GAMMA (X)
C JUNE 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
C
C  LOCAL SCALARS
      REAL DXREL,PI,SINPIY,SQ2PIL,XMAX,XMIN,Y
      INTEGER I,N,NGCS
C
C  LOCAL ARRAYS
      REAL GCS(23)
C
C  EXTERNAL FUNCTIONS
      REAL CSEVL,R1MACH,R9LGMC
      INTEGER INITS
      EXTERNAL CSEVL,R1MACH,R9LGMC,INITS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GAMLIM,XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,AINT,EXP,FLOAT,LOG,SIN,SQRT
C
C
      DATA GCS   ( 1) / .0085711955 90989331E0/
      DATA GCS   ( 2) / .0044153813 24841007E0/
      DATA GCS   ( 3) / .0568504368 1599363E0/
      DATA GCS   ( 4) /-.0042198353 96418561E0/
      DATA GCS   ( 5) / .0013268081 81212460E0/
      DATA GCS   ( 6) /-.0001893024 529798880E0/
      DATA GCS   ( 7) / .0000360692 532744124E0/
      DATA GCS   ( 8) /-.0000060567 619044608E0/
      DATA GCS   ( 9) / .0000010558 295463022E0/
      DATA GCS   (10) /-.0000001811 967365542E0/
      DATA GCS   (11) / .0000000311 772496471E0/
      DATA GCS   (12) /-.0000000053 542196390E0/
      DATA GCS   (13) / .0000000009 193275519E0/
      DATA GCS   (14) /-.0000000001 577941280E0/
      DATA GCS   (15) / .0000000000 270798062E0/
      DATA GCS   (16) /-.0000000000 046468186E0/
      DATA GCS   (17) / .0000000000 007973350E0/
      DATA GCS   (18) /-.0000000000 001368078E0/
      DATA GCS   (19) / .0000000000 000234731E0/
      DATA GCS   (20) /-.0000000000 000040274E0/
      DATA GCS   (21) / .0000000000 000006910E0/
      DATA GCS   (22) /-.0000000000 000001185E0/
      DATA GCS   (23) / .0000000000 000000203E0/
C
      DATA PI /3.14159 26535 89793 24E0/
C SQ2PIL IS LOG (SQRT (2.*PI) )
      DATA SQ2PIL /0.91893 85332 04672 74E0/
      DATA NGCS, XMIN, XMAX, DXREL /0, 3*0.0 /
C
      IF (NGCS.NE.0) GO TO 10
C
C ---------------------------------------------------------------------
C INITIALIZE.  FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF
C TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER
C THAN MACHINE PRECISION.
C
      NGCS = INITS (GCS, 23, 0.1*R1MACH(3))
C
      CALL GAMLIM (XMIN, XMAX)
      DXREL = SQRT (R1MACH(4))
C
C ---------------------------------------------------------------------
C FINISH INITIALIZATION.  START EVALUATING GAMMA(X).
C
 10   Y = ABS(X)
      IF (Y.GT.10.0) GO TO 50
C
C COMPUTE GAMMA(X) FOR ABS(X) .LE. 10.0.  REDUCE INTERVAL AND
C FIND GAMMA(1+Y) FOR 0. .LE. Y .LT. 1. FIRST OF ALL.
C
      N = X
      IF (X.LT.0.) N = N - 1
      Y = X - FLOAT(N)
      N = N - 1
      GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
C COMPUTE GAMMA(X) FOR X .LT. 1.
C
      N = -N
      IF (X.EQ.0.) CALL XERROR ('GAMMA   X IS 0', 14, 4, 2)
      IF (X.LT.0. .AND. X+FLOAT(N-2).EQ.0.) CALL XERROR (
     1  'GAMMA   X IS A NEGATIVE INTEGER', 31, 4, 2)
      IF (X.LT.(-0.5) .AND. ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL
     1  XERROR (  'GAMMA   ANSWER LT HALF PRECISION BECAUSE X TOO NEAR N
     2EGATIVE INTEGER', 68, 1, 1)
C
      DO 20 I=1,N
        GAMMA = GAMMA / (X+FLOAT(I-1))
 20   CONTINUE
      RETURN
C
C GAMMA(X) FOR X .GE. 2.
C
 30   DO 40 I=1,N
        GAMMA = (Y+FLOAT(I))*GAMMA
 40   CONTINUE
      RETURN
C
C COMPUTE GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
C
 50   IF (X.GT.XMAX) CALL XERROR ('GAMMA   X SO BIG GAMMA OVERFLOWS',
     1  32, 3, 2)
C
      GAMMA = 0.
      IF (X.LT.XMIN) CALL XERROR ('GAMMA   X SO SMALL GAMMA UNDERFLOWS',
     1  35, 2, 1)
      IF (X.LT.XMIN) RETURN
C
      GAMMA = EXP((Y-0.5)*LOG(Y) - Y + SQ2PIL + R9LGMC(Y) )
      IF (X.GT.0.) RETURN
C
      IF (ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL XERROR (
     1  'GAMMA   ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER',
     2  61, 1, 1)
C
      SINPIY = SIN (PI*Y)
      IF (SINPIY.EQ.0.) CALL XERROR (
     1  'GAMMA   X IS A NEGATIVE INTEGER', 31, 4, 2)
C
      GAMMA = -PI / (Y*SINPIY*GAMMA)
C
      RETURN
      END
*GAMR
      REAL FUNCTION GAMR (X)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C THIS ROUTINE, NOT GAMMA(X), SHOULD BE THE FUNDAMENTAL ONE.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
C
C  LOCAL SCALARS
      REAL ALNGX,SGNGX
      INTEGER IROLD
C
C  EXTERNAL FUNCTIONS
      REAL GAMMA
      EXTERNAL GAMMA
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ALGAMS,XERCLR,XGETF,XSETF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,AINT,EXP
C
      GAMR = 0.0
      IF (X.LE.0.0 .AND. AINT(X).EQ.X) RETURN
C
      CALL XGETF (IROLD)
      CALL XSETF (1)
      IF (ABS(X).GT.10.0) GO TO 10
      GAMR = 1.0/GAMMA(X)
      CALL XERCLR
      CALL XSETF (IROLD)
      RETURN
C
 10   CALL ALGAMS (X, ALNGX, SGNGX)
      CALL XERCLR
      CALL XSETF (IROLD)
      GAMR = SGNGX * EXP(-ALNGX)
      RETURN
C
      END
*GENI
      SUBROUTINE GENI(IVECT, N, IINIT, ISTP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     PUT VALUES IINIT STEP ISTP THROUGH IINIT + (N - 1)*ISTP INTO
C     A VECTOR IVECT OF LENGTH N.  NO ERROR CHECKING IS DONE.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING LAB/BOULDER
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IINIT,ISTP,N
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IVECT(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        INITIALIZATION VALUE.
C     INTEGER IINIT, ISTP
C        INPUT PARAMETERS.  THE INITIAL VALUE AND THE INCREMENT USED
C        IN CREATING THE INITIALIZATION VALUES.
C     INTEGER IVECT(N)
C        OUTPUT PARAMETER.  THE VECTOR INTO WHICH TO PUT THE VALUES
C        IINIT, IINIT + ISTP, ..., IINIT + (N - 1)*ISTP.
C     INTEGER J
C        LOOP PARAMETER.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF IVECT.
C
      I = IINIT
      DO 10 J=1,N
         IVECT(J) = I
         I = I + ISTP
   10 CONTINUE
      RETURN
      END
*GENR
      SUBROUTINE GENR(RVECT, N, RINIT, RSTP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     PUT VALUES RINIT STEP RSTP THROUGH RINIT + (N - 1)*RSTP INTO
C     A VECTOR RVECT OF LENGTH N.  NO ERROR CHECKING IS DONE.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING LAB/BOULDER
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   RINIT,RSTP
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   RVECT(N)
C
C  LOCAL SCALARS
      REAL
     +   R
      INTEGER
     +   J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER J
C        LOOP PARAMETER.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF RVECT.
C     REAL R
C        INITIALIZATION VALUE.
C     REAL RINIT, RSTP
C        INPUT PARAMETERS.  THE INITIAL VALUE AND THE INCREMENT USED
C        IN CREATING THE INITIALIZATION VALUES.
C     REAL RVECT(N)
C        OUTPUT PARAMETER.  THE VECTOR INTO WHICH TO PUT THE VALUES
C        RINIT, RINIT + RSTP, ..., RINIT + (N - 1)*RSTP.
C
      R = RINIT
      DO 10 J=1,N
         RVECT(J) = R
         R = R + RSTP
   10 CONTINUE
      RETURN
      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
      REAL
     +   PI
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL PI
C        THE VALUE OF PI.
C
      PI = 3.141592653589793238462643383279E0
      RETURN
      END
*GFAEST
      SUBROUTINE GFAEST (PHI, IAR, NF, FREQ, GAIN, PHAS, DELTA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE GAIN FUNCTION OF AN AUTOREGRESSIVE
C     LINEAR FILTER USING THE ALGORITHM GIVEN ON PAGES 419 AND 420
C     JENKINS AND WATTS.
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
      REAL
     +   DELTA
      INTEGER
     +   IAR,NF
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),GAIN(NF),PHAS(NF),PHI(IAR)
C
C  LOCAL SCALARS
      REAL
     +   ARG,C,PI,S,V0,V1,V2,Z0,Z1,Z2
      INTEGER
     +   I,J,JJ
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ATAN2,COS,SIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ARG
C        A VALUE USED TO COMPUTE THE GAIN FUNCTION ESTIMATES.
C     REAL C
C        A VALUE USED TO COMPUTE THE GAIN FUNCTION ESTIMATES.
C     REAL DELTA
C        THE SAMPLING INTERVAL OF THE ORIGINAL SERIES.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO
C        BE ESTIMATED.
C     REAL GAIN(NF)
C        THE ARRAY IN WHICH THE GAIN FUNCTION ESTIMATES ARE RETURNED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
C     INTEGER J, JJ
C        INDEX VARIABLES.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE GAIN FUNCTION ESTIMATES
C        ARE TO BE COMPUTED.
C     REAL PHAS(NF)
C        THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED.
C     REAL PHI(IAR)
C        THE VECTOR CONTAINING THE AUTOREGRESSIVE FILTER COEFFICIENTS.
C     REAL PI
C        THE VALUE OF PI.
C     REAL S
C        A VALUE USED TO COMPUTE THE GAIN FUNCTION ESTIMATES.
C     REAL V0, V1, V2
C        CONSTANTS USED FOR COMPUTING THE GAIN FUNCTION ESTIMATES.
C     REAL Z0, Z1, Z2
C        CONSTANTS USED FOR COMPUTING THE GAIN FUNCTION ESTIMATES.
C
      CALL GETPI(PI)
C
C     COMPUTE GAIN FUNCTION ESTIMATES AND THEIR CONFIDENCE LIMITS.
C
      DO 30 I = 1, NF
         IF (FREQ(I).EQ.0.0E0) THEN
            ARG = 0.0E0
            C = 1.0E0
            S = 0.0E0
         ELSE IF (FREQ(I).EQ.0.25E0) THEN
            ARG = PI/2.0E0
            C = 0.0E0
            S = 1.0E0
         ELSE IF (FREQ(I).EQ.0.5E0) THEN
            ARG = PI
            C = -1.0E0
            S = 0.0E0
         ELSE
            ARG = 2.0E0 * PI * FREQ(I)
            C = COS(ARG)
            S = SIN(ARG)
         END IF
         V0 = 0.0E0
         V1 = 0.0E0
         Z0 = 0.0E0
         Z1 = 0.0E0
C
         JJ = IAR + 1
C
         DO 20 J = 1, IAR
            JJ = JJ -1
C
            V2 = C * V1 - V0 - PHI(JJ)
            V0 = V1
            V1 = V2
C
            Z2 = S * Z1 - Z0 - PHI(JJ)
            Z0 = Z1
            Z1 = Z2
   20    CONTINUE
C
         V2 = DELTA * (1.0E0 + (V1 * C - V0))
C
         Z2 = DELTA * Z1 * S
C
         GAIN(I) = SQRT(V2*V2 + Z2*Z2)
C
         PHAS(I) = -0.5E0 * PI
         IF (Z2.NE.0.0E0 .AND. V2.NE.0.0E0) PHAS(I) = ATAN2(Z2, V2)
C
   30 CONTINUE
C
      RETURN
      END
*GFARF
      SUBROUTINE GFARF (PHI, IAR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE TO COMPUTE THE GAIN
C     FUNCTION OF AN AUTOREGRESSIVE FILTER (SHORT CALL).
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
     +   IAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PHI(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   DELTA,FMAX,FMIN,YPLTMN,YPLTMX
      INTEGER
     +   IGFERR,IPRT,NF,NORD,NPRT
      LOGICAL
     +   ERR01,HEAD,SYM
C
C  LOCAL ARRAYS
      REAL
     +   FREQ(101),GAIN(101),PHAS(101),XORD(101),YORD(101)
      INTEGER
     +   ISORT(101)
      CHARACTER
     +   LIAR(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,GFAEST,GFORD,GFOUT,IPRINT,SETFRQ
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     LOGICAL ERR01
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FMAX, FMIN
C        THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN
C        FUNCTION IS TO BE ESTIMATED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        HAS BEEN ESTIMATED.
C     REAL GAIN(101)
C        THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE
C        STORED.
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 IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
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 IGFERR
C        AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM
C        TO HAVE PRODUCED REASONABLE RESULTS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     CHARACTER*1 LIAR(8)
C        THE ARRAY CONTAINING THE NAME OF THE VARIABLE IAR.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        IS TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NORD
C        THE NUMBER OF VALUES TO BE PLOTTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBELS/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     REAL PHAS(101)
C        THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED.
C     REAL PHI(IAR)
C        THE VECTOR CONTAINING THE FILTER COEFFICIENTS.
C     LOGICAL SYM
C        THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION
C        COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER.
C     REAL XORD(101)
C        THE X COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL YORD(101)
C        THE Y COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'G',       'F',       'A',       'R',       'F',       ' '/
      DATA
     +  LIAR(1), LIAR(2), LIAR(3), LIAR(4), LIAR(5), LIAR(6), LIAR(7),
     +  LIAR(8)
     + /  'I',   'A',   'R',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LIAR, IAR, 1, 1, HEAD, ERR01, LIAR)
C
      IF (.NOT. ERR01) GO TO 10
C
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SYM = .FALSE.
C
      NF = 101
C
      FMIN = 0.0E0
      FMAX = 0.5E0
C
      DELTA = 1.0E0
C
      NPRT = -1
C
C     SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED
C
      CALL SETFRQ (FREQ, NF, NPRT, FMIN, FMAX, DELTA)
C
C     COMPUTE THE GAIN FUNCTION
C
      CALL GFAEST (PHI, IAR, NF, FREQ, GAIN, PHAS, DELTA)
C
C     SET THE COORDINATES FOR THE PLOT.
C
      CALL GFORD (FREQ, GAIN, ISORT, NF, XORD, YORD, NORD,
     +   YPLTMN, YPLTMX, NPRT, IGFERR)
C
C     PLOT THE RESULTS.
C
      CALL GFOUT (XORD, YORD, NORD, FREQ, PHAS, NF, IAR, SYM, FMIN,
     +   FMAX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   28H       CALL GFARF (PHI, IAR))
      END
*GFARFS
      SUBROUTINE GFARFS (PHI, IAR, NF, FMIN, FMAX, GAIN, PHAS, FREQ,
     +   NPRT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE TO COMPUTE THE GAIN
C     FUNCTION OF AN AUTOREGRESSIVE FILTER (SHORT CALL).
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
      REAL
     +   FMAX,FMIN
      INTEGER
     +   IAR,LDSTAK,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),GAIN(*),PHAS(*),PHI(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   DELTA,FMN,FMX,YPLTMN,YPLTMX
      INTEGER
     +   IGFERR,IO,IPRT,ISORT,LDSMIN,NALL0,NORD,XORD,YORD
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD,SYM
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   LIAR(8)*1,LLDS(8)*1,LNF(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,GFAEST,GFORD,GFOUT,IPRINT,LDSCMP,SETFRQ,STKCLR,
     +   STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03
C        VALUES INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FMAX, FMIN
C        THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN
C        FUNCTION IS TO BE ESTIMATED.
C     REAL FMN, FMX
C        THE FREQUENCY RANGE ACTUALLY USED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        HAS BEEN ESTIMATED.
C     REAL GAIN(NF)
C        THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE
C        STORED.
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 IAR
C        THE NUMBER OF FILTER COEFFICIENTS.
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 IGFERR
C        AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM
C        TO HAVE PRODUCED REASONABLE RESULTS.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION IN ISTAK FOR
C        THE ARRAY USED FOR SORTING.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     CHARACTER*1 LIAR(8), LLDS(8), LNF(8)
C        THE ARRAYS CONTAINING THE NAMES OF CHECKED VARIABLES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        IS TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NORD
C        THE NUMBER OF POINTS TO BE PLOTTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBELS/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     REAL PHAS(NF)
C        THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED.
C     REAL PHI(IAR)
C        THE VECTOR CONTAINING THE FILTER COEFFICIENTS.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL SYM
C        THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION
C        COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER.
C     INTEGER XORD
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE X COORDINATES FOR THE GAIN FUNCTION PLOT
C     INTEGER YORD
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE Y COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'G',       'F',       'A',       'R',       'F',       'S'/
      DATA
     +  LIAR(1), LIAR(2), LIAR(3), LIAR(4), LIAR(5), LIAR(6),
     +  LIAR(7), LIAR(8) /'I', 'A', 'R', ' ', ' ', ' ', ' ', ' '/
      DATA
     +  LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7),
     +  LLDS(8) /  'L',   'D',   'S',   'T',   'A',   'K',   ' ',   ' '/
      DATA
     +  LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8)
     + /  'N',   'F',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LIAR, IAR, 1, 1, HEAD, ERR01, LIAR)
C
      CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR02, LNF)
C
      IF (ERR02) GO TO 10
C
      CALL LDSCMP(3*IO, 0, NF, 0, 0, 0, 'S', 2*IO*NF, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS)
C
      IF (ERR01.OR.ERR02.OR.ERR03) GO TO 10
      GO TO 20
C
   10   IERR = 1
        CALL IPRINT (IPRT)
        WRITE (IPRT, 1000)
        RETURN
C
   20 CONTINUE
C
      IF (NPRT .NE. 0) THEN
        CALL STKSET (LDSTAK, 4)
        NALL0 = STKST(1)
      ELSE
        NALL0 = 0
      END IF
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SYM = .FALSE.
C
      DELTA = 1.0E0
C
C     SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED
C
      FMN = MAX(FMIN, 0.0E0)
      FMX = MIN(FMAX, 0.5E0)
      IF (FMN.GE.FMX) THEN
        FMN = 0.0E0
        FMX = 0.5E0
      END IF
      CALL SETFRQ (FREQ, NF, 2, FMN, FMX, DELTA)
C
C     COMPUTE THE GAIN FUNCTION
C
      CALL GFAEST (PHI, IAR, NF, FREQ, GAIN, PHAS, DELTA)
C
      IF (NPRT .EQ. 0) RETURN
C
C     SET VARIOUS POINTERS FOR THE PLOTTING ARRAYS
C
      XORD = STKGET(NF, 3)
      YORD = STKGET(NF, 3)
C
      ISORT = STKGET(NF, 2)
C
      IF (IERR .EQ. 1) GO TO 10
C
C     PLOT THE RESULTS
C
      CALL GFORD (FREQ, GAIN, ISTAK(ISORT), NF, RSTAK(XORD),
     +   RSTAK(YORD), NORD, YPLTMN, YPLTMX, NPRT, IGFERR)
      CALL GFOUT (RSTAK(XORD), RSTAK(YORD), NORD, FREQ, PHAS, NF,
     +   IAR, SYM, FMN, FMX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB)
C
      CALL STKCLR(NALL0)
C
      IF (IERR .EQ. 1) GO TO 10
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL GFARFS (PHI, IAR,'/
     + '      +             NF, FMIN, FMAX, GAIN, PHAS, FREQ, NPRT,',
     + ' LDSTAK)')
      END
*GFORD
      SUBROUTINE GFORD (FREQ, GAIN, ISORT, NF, XORD, YORD,
     +   NORD, YPLTMN, YPLTMX, NPRT, IGFERR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES ORDANENTS FOR THE GAIN FUNCTION PLOTS.
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
      REAL
     +   YPLTMN,YPLTMX
      INTEGER
     +   IGFERR,NF,NORD,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),GAIN(NF),XORD(NF),YORD(NF)
      INTEGER
     +   ISORT(NF)
C
C  LOCAL SCALARS
      REAL
     +   GAINMN,GAINMX,YMAX
      INTEGER
     +   I,J
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SPCCK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     REAL GAIN(NF)
C        THE VECTOR IN WHICH THE GAIN FUNCTION IS STORED.
C     REAL GAINMN, GAINMX
C        THE MINIMUM AND MAXIMUM GAIN FUNCTION VALUE TO BE PLOTTED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER IGFERR
C        AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM
C        TO HAVE PRODUCED REASONABLE RESULTS.
C     INTEGER ISORT(NF)
C        THE ARRAY USED FOR SORTING.
C     INTEGER J
C        AN INDEXING VARIABLE.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES
C        ARE TO BE ESTIMATED.
C     INTEGER NORD
C        THE NUMBER OF ORDINATES TO BE PLOTTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBELS/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     REAL XORD(NF)
C        THE X ORDINATES FOR THE SPECTRUM PLOT.
C     REAL YMAX
C        THE MAXIMUM ACTUAL SPECTRUM VALUE (IN DECIBELS) TO BE PLOTTED.
C     REAL YORD(NF)
C        THE Y ORDINATES FOR THE SPECTRUM PLOTS.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS.
C
      IGFERR = 0
C
      CALL SPCCK (GAIN, ISORT, NF, GAINMN, GAINMX, NORD, IGFERR)
C
      IF (IGFERR .NE. 0) RETURN
C
      J = 0
C
      IF (NPRT.GE.1) GO TO 30
C
C     SET ORDINATES FOR DECIBLE PLOTS
C
      YMAX = 10.0E0 * LOG10(GAINMX)
C
      YPLTMX = 0.0E0
      YPLTMN = 10.0E0 * LOG10(GAINMN) - YMAX
C
      DO 10 I = 1, NF
         IF (GAIN(I) .LT. GAINMN) GO TO 10
         J = J + 1
         XORD(J) = FREQ(I)
         YORD(J) = 10.0E0 * LOG10(GAIN(I)) - YMAX
   10 CONTINUE
C
      RETURN
C
   30 CONTINUE
C
      YPLTMX = GAINMX
      YPLTMN = GAINMN
C
C     SET ORDINATES FOR LOG PLOTS
C
      DO 50 I = 1, NF
         IF (GAIN(I) .LT. GAINMN) GO TO 50
         J = J + 1
         XORD(J) = FREQ(I)
         YORD(J) = GAIN(I)
   50 CONTINUE
C
      RETURN
      END
*GFOUT
      SUBROUTINE GFOUT (XORD, YORD, NORD, FREQ, PHAS, NF,
     +   NTERM, SYM, XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT, IGFERR,
     +   NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES THE GAIN FUNCTION PLOTS.
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
      REAL
     +   XPLTMN,XPLTMX,YPLTMN,YPLTMX
      INTEGER
     +   IGFERR,NF,NORD,NPRT,NTERM
      LOGICAL
     +   SYM
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),PHAS(NF),XORD(NORD),YORD(NORD)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   PI,XMN,XMX,YMN,YMX
      INTEGER
     +   ILOG,IPRT
      LOGICAL
     +   ERROR
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI,IPRINT,PPLMT,PPMN,VERSP
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        AN ERROR FLAG.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO
C        BE ESTIMATED.
C     INTEGER IERR
C        THE ERROR FLAG.
C     INTEGER IGFERR
C        AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM
C        TO HAVE PRODUCED REASONABLE RESULTS.
C     INTEGER ILOG
C        THE VARIABLE CONTROLLING THE PLOT AXIS TYPE (LOG OR LINEAR)
C     INTEGER IPRT
C        THE UNIT NUMBER FOR THE OUTPUT.
C     INTEGER ISYM(1)
C        A DUMMY ARRAY FOR THE CALL TO PPMN.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE GAIN FUNCTION ESTIMATES
C        ARE TO BE COMPUTED.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE.
C     INTEGER NORD
C        THE NUMBER OF ORDINATES TO BE PLOTTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBELS/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NTERM
C        THE NUMBER OF TERMS IN THE FILTER FOR WHICH THE GAIN
C        FUNCTION WAS COMPUTED.
C     REAL PHAS(NF)
C        THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED.
C     REAL PI
C        THE VALUE OF PI.
C     LOGICAL SYM
C        AN INDICATOR VARIABLE USED TO DETERMINE IF THE FILTER WAS
C        SYMMETRIC OR NOT.
C     REAL XMN, XMX
C        ...
C     REAL XORD(NORD)
C        THE X COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YMN, YMX
C        ...
C     REAL YORD(NORD)
C        THE Y COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH.
C
      CALL IPRINT (IPRT)
C
      CALL VERSP(.TRUE.)
C
      IF (SYM) WRITE (IPRT, 1000) NTERM
      IF (.NOT. SYM) WRITE (IPRT, 1003) NTERM
C
      IF (IGFERR .EQ. 0) GO TO 5
      WRITE (IPRT, 1004)
      RETURN
C
    5 CONTINUE
C
      IF (NPRT.GE.1) THEN
        ILOG = 1
      ELSE
        ILOG = 0
      END IF
C
C     DETERMINE THE BOUNDS FOR THE X AND Y AXIS AND COMPLETE THE
C     ERROR CHECKING
C
      CALL PPLMT (YORD, YORD, XORD, XORD, NORD, 1, NORD,
     +   YPLTMN, YPLTMX, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX,
     +   ERROR, NMSUB, .FALSE.)
      IF (ERROR) THEN
        IERR = 1
        RETURN
      ELSE
        CALL PPMN (YORD, YORD, XORD, XORD, NORD, 1, NORD, 0, ISYM, 1, 0,
     +   0, YMN, YMX, XMN, XMX, .FALSE., ILOG)
      END IF
C
      IF (XPLTMN .NE. 0.0E0 .OR. XPLTMX .NE. 0.5E0) GO TO 10
C
      WRITE (IPRT, 1002)
C
   10 IF (SYM) RETURN
C
      WRITE (IPRT, 1006)
C
      CALL VERSP(.TRUE.)
C
C     PRINT PHASE PLOT FOR AUTOREGRESSIVE FILTER
C
      CALL GETPI(PI)
C
      WRITE (IPRT, 1005) NTERM
C
      CALL PPLMT (PHAS, PHAS, FREQ, FREQ, NORD, 1, NORD,
     +   -PI, PI, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX,
     +   ERROR, NMSUB, .FALSE.)
      IF (ERROR) THEN
        IERR = 1
        RETURN
      ELSE
        CALL PPMN (PHAS, PHAS, FREQ, FREQ, NORD, 1, NORD, 0, ISYM, 1, 0,
     +   0, YMN, YMX, XMN, XMX, .FALSE., 0)
      END IF
C
      IF (XPLTMN .NE. 0.0E0 .OR. XPLTMX .NE. 0.5E0) RETURN
C
      WRITE (IPRT, 1002)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (18H GAIN FUNCTION OF , I3, 15H TERM SYMMETRIC,
     +   14H LINEAR FILTER)
 1002 FORMAT(5H+FREQ/
     +   7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X,
     +   2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X,
     +   6H2.2222, 4X, 2H2.)
 1003 FORMAT (18H GAIN FUNCTION OF , I3, 21H TERM AUTOREGRESSIVE,,
     +   22H OR DIFFERENCE, FILTER)
 1004 FORMAT (//51H THE PLOT HAS BEEN SUPRESSED BECAUSE FEWER THAN TWO/
     +   45H NON ZERO GAIN FUNCTION VALUES WERE COMPUTED.)
 1005 FORMAT (19H PHASE FUNCTION OF , I3, 21H TERM AUTOREGRESSIVE,,
     +   22H OR DIFFERENCE, FILTER)
 1006 FORMAT ('1')
      END
*GFSEST
      SUBROUTINE GFSEST (H, K, NF, FREQ, GAIN, DELTA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE GAIN FUNCTION OF AN INPUT SYMMETRIC
C     LINEAR FILTER AT THE FREQUENCIES SPECIFIED IN FREQ USING THE
C     TRANSFORM ALGORITHM SHOWN ON PAGE 311 OF JENKINS AND WATTS.
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
      REAL
     +   DELTA
      INTEGER
     +   K,NF
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),GAIN(NF),H(K)
C
C  LOCAL SCALARS
      REAL
     +   C,PI,V0,V1,V2
      INTEGER
     +   I,J,KHALF,KMID
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,COS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL C
C        A VALUE USED TO COMPUTE THE GAIN FUNCTION.
C     REAL DELTA
C        THE SAMPLING INTERVAL OF THE ORIGINAL SERIES.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE
C        ESTIMATED.
C     REAL GAIN(NF)
C        THE ARRAY IN WHICH THE GAIN FUNCTION ESTIMATES ARE RETURNED.
C     REAL H(K)
C        THE SYMMETRIC LINEAR FILTER WEIGHTS.
C     INTEGER I, J
C        INDEX VARIABLES.
C     INTEGER K
C        THE NUMBER OF TERMS IN THE SYMMETRIC LINEAR FILTER.
C     INTEGER KHALF, KMID
C        HALF THE FILTER LENGTH, AND THE MIDPOINT OF THE FILTER,
C        RESPECTIVELY.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE GAIN FUNCTION ESTIMATES
C        ARE TO BE ESTIMATED.
C     REAL PI
C        THE VALUE OF PI.
C     REAL V0, V1, V2
C        CONSTANTS USED FOR COMPUTING THE GAIN FUNCTION ESTIMATES.
C
      CALL GETPI(PI)
C
C        COMPUTE GAIN FUNCTION ESTIMATES AND THEIR CONFIDENCE LIMITS.
C
      KMID = (K+1) / 2
      KHALF = KMID - 1
C
      DO 30 I = 1, NF
         C = COS(2.0E0 * PI * FREQ(I))
         V0 = 0.0E0
         V1 = 0.0E0
         DO 20 J = 1, KHALF
            V2 = 2.0E0 * C * V1 - V0 + H(J)
            V0 = V1
            V1 = V2
   20    CONTINUE
         GAIN(I) = ABS(DELTA * (H(KMID) + 2.0E0 * (V1 * C - V0)))
   30 CONTINUE
      RETURN
      END
*GFSLF
      SUBROUTINE GFSLF (H, K)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE
C     GAIN FUNCTION OF A SYMMETRIC LINEAR FILTER (SHORT CALL).
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
      REAL
     +   H(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   DELTA,FMAX,FMIN,YPLTMN,YPLTMX
      INTEGER
     +   IGFERR,IPRT,NF,NORD,NPRT
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD,SYM
C
C  LOCAL ARRAYS
      REAL
     +   FREQ(101),GAIN(101),XORD(101),YORD(101)
      INTEGER
     +   ISORT(101)
      CHARACTER
     +   LH(8)*1,LK(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ERIODD,ERSLF,GFORD,GFOUT,GFSEST,IPRINT,SETFRQ
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     LOGICAL ERR01, ERR02, ERR03
C        VALUES INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FMAX, FMIN
C        THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN
C        FUNCTION IS TO BE ESTIMATED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        HAS BEEN ESTIMATED.
C     REAL GAIN(101)
C        THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE
C        STORED.
C     REAL H(K)
C        THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS.
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 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 IGFERR
C        AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM
C        TO HAVE PRODUCED REASONABLE RESULTS.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER ISORT(101)
C        THE ARRAY USED FOR SORTING.
C     INTEGER K
C        THE NUMBER OF FILTER TERMS.
C     CHARACTER*1 LH(8), LK(8)
C        THE ARRAY CONTAINING THE NAME OF THE VARIABLES H AND K.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        IS TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NORD
C        THE NUMBER OF POINTS TO BE PLOTTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBELS/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     LOGICAL SYM
C        THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION
C        COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER.
C     REAL XORD(101)
C        THE X COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL YORD(101)
C        THE Y COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'G',       'F',       'S',       'L',       'F',       ' '/
      DATA
     +  LH(1), LH(2), LH(3), LH(4), LH(5), LH(6), LH(7), LH(8)
     + /  'H',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8)
     + /  'K',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LK, K, 1, 1, HEAD, ERR01, LK)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR02)
C
      IF ((.NOT. ERR01) .AND. (.NOT. ERR02)) THEN
         CALL ERSLF(NMSUB, LH, K, H, HEAD, ERR03)
      ELSE
         ERR03 = .FALSE.
      END IF
C
      IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SYM = .TRUE.
      NF = 101
C
      FMIN = 0.0E0
      FMAX = 0.5E0
C
      DELTA = 1.0E0
C
      NPRT = -1
C
C     SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED
C
      CALL SETFRQ (FREQ, NF, NPRT, FMIN, FMAX, DELTA)
C
C     COMPUTE THE GAIN FUNCTION
C
      CALL GFSEST (H, K, NF, FREQ, GAIN, DELTA)
C
C     PLOT THE RESULTS
C
      CALL GFORD (FREQ, GAIN, ISORT, NF, XORD, YORD, NORD,
     +   YPLTMN, YPLTMX, NPRT, IGFERR)
C
      CALL GFOUT (XORD, YORD, NORD, FREQ, GAIN, NF, K,
     +   SYM, FMIN, FMAX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   24H       CALL GFSLF (H, K))
      END
*GFSLFS
      SUBROUTINE GFSLFS (H, K, NF, FMIN, FMAX, GAIN, FREQ, NPRT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE
C     GAIN FUNCTION OF A SYMMETRIC LINEAR FILTER (SHORT CALL).
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
      REAL
     +   FMAX,FMIN
      INTEGER
     +   K,LDSTAK,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),GAIN(*),H(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   DELTA,FMN,FMX,YPLTMN,YPLTMX
      INTEGER
     +   IGFERR,IO,IPRT,ISORT,LDSMIN,NALL0,NORD,XORD,YORD
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,HEAD,SYM
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   LH(8)*1,LK(8)*1,LLDS(8)*1,LNF(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ERIODD,ERSLF,GFORD,GFOUT,GFSEST,IPRINT,LDSCMP,
     +   SETFRQ,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FMAX, FMIN
C        THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN
C        FUNCTION IS TO BE ESTIMATED.
C     REAL FMN, FMX
C        THE FREQUENCY RANGE ACTUALLY USED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        HAS BEEN ESTIMATED.
C     REAL GAIN(NF)
C        THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE
C        STORED.
C     REAL H(K)
C        THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS.
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 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 IGFERR
C        AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM
C        TO HAVE PRODUCED REASONABLE RESULTS.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION IN ISTAK FOR
C        THE ARRAY USED FOR SORTING.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER K
C        THE NUMBER OF FILTER TERMS.
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 LH(8), LK(8), LLDS(8), LNF(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE CHECKED VARIABLES
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION
C        IS TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NORD
C        THE NUMBER OF POINTS TO BE PLOTTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBELS/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL SYM
C        THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION
C        COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER.
C     INTEGER XORD
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE X COORDINATES FOR THE GAIN FUNCTION PLOT
C     INTEGER YORD
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE Y COORDINATES FOR THE GAIN FUNCTION PLOT
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'G',       'F',       'S',       'L',       'F',       'S'/
      DATA
     +  LH(1), LH(2), LH(3), LH(4), LH(5), LH(6), LH(7), LH(8)
     + /  'H',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LK(1), LK(2), LK(3), LK(4), LK(5), LK(6),
     +  LK(7), LK(8) /'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA
     +  LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7),
     +  LLDS(8) /  'L',   'D',   'S',   'T',   'A',   'K',   ' ',   ' '/
      DATA
     +  LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8)
     + /  'N',   'F',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LK, K, 1, 1, HEAD, ERR01, LK)
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR02)
      ERR03 = .TRUE.
      IF ((.NOT. ERR01) .AND. (.NOT. ERR02))
     +   CALL ERSLF(NMSUB, LH, K, H, HEAD, ERR03)
      CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR04, LNF)
C
      IF (ERR04) GO TO 10
C
      CALL LDSCMP(3*IO, 0, IO*NF, 0, 0, 0, 'S', 2*IO*NF, LDSMIN)
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR05, LLDS)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR05) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
      IF (NPRT .NE. 0) THEN
        CALL STKSET (LDSTAK, 4)
        NALL0 = STKST(1)
      ELSE
        NALL0 = 0
      END IF
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SYM = .TRUE.
C
      DELTA = 1.0E0
C
C     SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED
C
      FMN = MAX(FMIN, 0.0E0)
      FMX = MIN(FMAX, 0.5E0)
      IF (FMN.GE.FMX) THEN
        FMN = 0.0E0
        FMX = 0.5E0
      END IF
      CALL SETFRQ (FREQ, NF, 2, FMN, FMX, DELTA)
C
C     COMPUTE THE GAIN FUNCTION
C
      CALL GFSEST (H, K, NF, FREQ, GAIN, DELTA)
C
      IF (NPRT .EQ. 0) RETURN
C
C     SET VARIOUS POINTERS FOR THE PLOTTING ARRAYS
C
      XORD = STKGET(NF, 3)
      YORD = STKGET(NF, 3)
C
      ISORT = STKGET(NF, 2)
C
      IF (IERR .EQ. 1) GO TO 10
C
C     PLOT THE RESULTS
C
      CALL GFORD (FREQ, GAIN, ISTAK(ISORT), NF, RSTAK(XORD),
     +   RSTAK(YORD), NORD, YPLTMN, YPLTMX, NPRT, IGFERR)
      CALL GFOUT (RSTAK(XORD), RSTAK(YORD), NORD, FREQ, GAIN, NF, K,
     +   SYM, FMN, FMX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB)
C
      CALL STKCLR(NALL0)
C
      IF (IERR .EQ. 1) GO TO 10
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL GFSLFS (H, K, NF, FMIN, FMAX, GAIN, FREQ, NPRT,',
     +   ' LDSTAK)')
      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
      REAL
     +   YMEAN
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   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     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     REAL YMEAN
C        THE GEOMETRIC MEAN OF THE OBSERVED SERIES
C
      YMEAN = 0.0E0
      DO 10 I = 1, N
         YMEAN = YMEAN + LOG(Y(I))
   10 CONTINUE
      YMEAN = EXP(YMEAN/N)
      RETURN
      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
      REAL
     +   D(P),DIG(P),DIHDI(1),L(1),STEP(P),V(21),W(1)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   DOTPRD,LSVMIN,RMDCON,V2NORM
      EXTERNAL DOTPRD,LSVMIN,RMDCON,V2NORM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL LITVMU,LIVMUL,LSQRT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,MIN,SQRT
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER KA, P
C     REAL 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 LSQRT  - 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     REAL 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     REAL 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, LSQRT, LSVMIN, RMDCON, V2NORM
C     REAL 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
      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.0E0/, EPSFAC/50.0E0/, FOUR/4.0E0/, HALF/0.5E0/,
     +     KAPPA/2.0E0/, NEGONE/-1.0E0/, ONE/1.0E0/, P001/1.0E-3/,
     +     SIX/6.0E0/, THREE/3.0E0/, TWO/2.0E0/, ZERO/0.0E0/
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.0E0
      PHI = 0.0E0
      DST = 0.0E0
      ALPHAK = 0.0E0
      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 LSQRT(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 LSQRT(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
*HIPASS
      SUBROUTINE HIPASS (Y, N, FC, K, HHP, YF, NYF)
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
      REAL
     +   FC
      INTEGER
     +   K,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   HHP(*),Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      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,IPRINT,LPFLT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
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     REAL 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     REAL 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     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
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.0E0,
     +           0.5E0, 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
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      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
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   46H       CALL HIPASS (Y, N, FC, K, HHP, YF, NYF))
      END
*HISTC
      SUBROUTINE HISTC (Y, N, NCELL, YLB, YUB, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR PRODUCING A HISTOGRAM
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  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YLB,YUB
      INTEGER
     +   LDSTAK,N,NCELL
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IDP,IFP,IINT,IPRT,LSORT,NALL0,NCELLS,YDIST
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL HSTER,HSTMN,IPRINT,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ANINT,LOG10,MIN,NINT,REAL
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 IDP
C        THE CODE VALUE FOR DOUBLE PRECISION FOR FRAMEWORK.
C     INTEGER IERR
C        THE CODE INDICATING WHETHER OR NOT AN ERROR HAS
C        BEEN DISCOVERED.  0 MEANS NO ERROR, NOT 0 MEANS
C        SOME ERROR EXISTS.
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IINT
C        THE CODE VALUE FOR INTEGER FOR FRAMEWORK
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 LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF DOUBLE PRECISION
C        ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM.
C     INTEGER LSORT
C        THE STARTING LOCATION IN ISTAK OF THE PERMUTATION
C        VECTOR.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     INTEGER NCELL
C        THE USER SUPPLIED VALUE FOR THE NUMBER OF CELLS IN THE
C        HISTOGRAM.  IF NCELL IS LESS THAN OR EQUAL TO ZERO, THE
C        NUMBER OF CELLS TO BE USED (NCELLS) WILL BE CALCULATED FROM
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NCELLS
C        THE NUMBER OF CELLS IN THE HISTOGRAM.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF DATA POINTS ON WHICH
C        THE STATISTICS ARE COMPUTED.  Y IS SORTED, BUT RESTORED
C        TO ITS ORIGINAL ORDER AFTERWARDS.
C     INTEGER YDIST
C        THE STARTING LOCATION IN RSTAK OF THE DISTRIBUTION VECTOR.
C     REAL YLB
C        THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C     REAL YUB
C        THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C
C     INITIALIZE NAME VECTORS
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'H',      'I',      'S',      'T',      'C',      ' '/
C
      DATA IDP /4/
      DATA IINT /2/
C
C     COMPUTE NCELLS
C
      IF ((NCELL.LE.0) .AND. (N.GE.1)) THEN
         NCELLS = MIN(NINT(5.5E0+1.5E0*ANINT(LOG10(REAL(N)))),25)
      ELSE
         NCELLS = NCELL
      END IF
C
C     CHECK FOR ERRORS IN THE INPUT PARAMETERS
C
      CALL HSTER(NMSUB, Y, N, NCELLS, LDSTAK, YLB, YUB, IERR)
      IF (IERR.EQ.0) GO TO 10
C
C     PRINT ERROR MESSAGE.
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     SET UP FRAMEWORK AREA.
C
   10 CALL STKSET (LDSTAK, IDP)
      NALL0 = STKST(1)
C
C     SET UP WORK VECTORS
C
      IFP = 3
C
      LSORT = STKGET(N,IINT)
      YDIST = STKGET(NCELLS,IFP)
C
C     COMPUTE THE HISTOGRAM.
C
      CALL HSTMN(Y, N, NCELLS, YLB, YUB, ISTAK(LSORT), RSTAK(YDIST))
C
C     RETURN THE WORK VECTORS.
C
      CALL STKCLR(NALL0)
      RETURN
C
C     FORMAT STATEMENTS.
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL HISTC (Y, N, NCELL, YLB, YUB, LDSTAK)')
      END
*HIST
      SUBROUTINE HIST(Y, N, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR PRODUCING A HISTOGRAM
C     (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   YLB,YUB
      INTEGER
     +   IDP,IFP,IINT,IPRT,LSORT,NALL0,NCELLS,YDIST
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL HSTER,HSTMN,IPRINT,STKCLR,STKSET
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ANINT,LOG10,MIN,NINT,REAL
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 IDP
C        THE CODE VALUE FOR DOUBLE PRECISION FOR FRAMEWORK.
C     INTEGER IERR
C        THE CODE INDICATING WHETHER OR NOT AN ERROR HAS
C        BEEN DISCOVERED.  0 MEANS NO ERROR, NOT 0 MEANS
C        SOME ERROR EXISTS.
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IINT
C        THE CODE VALUE FOR INTEGER FOR FRAMEWORK
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 LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF DOUBLE PRECISION
C        ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM.
C     INTEGER LSORT
C        THE STARTING LOCATION IN ISTAK OF THE PERMUTATION
C        VECTOR.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     INTEGER NCELLS
C        THE NUMBER OF CELLS IN THE HISTOGRAM.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF DATA POINTS ON WHICH
C        THE STATISTICS ARE COMPUTED.  Y IS SORTED, BUT RESTORED
C        TO ITS ORIGINAL ORDER AFTERWARDS.
C     INTEGER YDIST
C        THE STARTING LOCATION IN RSTAK OF THE DISTRIBUTION VECTOR.
C     REAL YLB
C        THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C     REAL YUB
C        THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C
C     INITIALIZE NAME VECTORS
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'H',      'I',      'S',      'T',      ' ',      ' '/
C
      DATA IDP /4/
      DATA IINT /2/
      DATA YLB/0.0E0/, YUB/0.0E0/
C
C     COMPUTE NCELLS
C
      IF (N.GE.1) THEN
         NCELLS = MIN(NINT(5.5E0+1.5E0*ANINT(LOG10(REAL(N)))),25)
      ELSE
         NCELLS = 1
      END IF
C
C     CHECK FOR ERRORS IN THE INPUT PARAMETERS
C
      CALL HSTER(NMSUB, Y, N, NCELLS, LDSTAK, YLB, YUB, IERR)
      IF (IERR.EQ.0) GO TO 10
C
C     PRINT ERROR MESSAGE.
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     SET UP FRAMEWORK AREA.
C
   10 CALL STKSET (LDSTAK, IDP)
      NALL0 = STKST(1)
C
C     SET UP WORK VECTORS
C
      IFP = 3
C
      LSORT = STKGET(N,IINT)
      YDIST = STKGET(NCELLS,IFP)
C
C     COMPUTE THE HISTOGRAM.
C
      CALL HSTMN(Y, N, NCELLS, YLB, YUB, ISTAK(LSORT), RSTAK(YDIST))
C
C     RETURN THE WORK VECTORS.
C
      CALL STKCLR(NALL0)
      RETURN
C
C     FORMAT STATEMENTS.
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL HIST (Y, N, LDSTAK)')
      END
*HPCOEF
      SUBROUTINE HPCOEF (HLP, K, HHP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTE THE HI-PASS FILTER CORRESPONDING
C     TO THE INPUT K TERM LOW PASS 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
      INTEGER
     +   K
C
C  ARRAY ARGUMENTS
      REAL
     +   HHP(*),HLP(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LHLP(8)*1,LK(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ERIODD,ERSLF,HPFLT,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03
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     REAL HHP(K)
C        THE ARRAY IN WHICH THE HIGH PASS FILTER COEFFICIENTS
C        WILL BE RETURNED.
C     REAL HLP(K)
C        THE ARRAY IN WHICH THE INPUT LOW PASS FILTER COEFFICIENTS
C        ARE STORED.
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 LHLP(8), LK(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES HLP AND K.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'H',       'P',       'C',       'O',       'E',       'F'/
      DATA
     +  LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8)
     + /  'K',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LHLP(1), LHLP(2), LHLP(3), LHLP(4), LHLP(5), LHLP(6), LHLP(7),
     +  LHLP(8)
     + /  'H',   'L',   'P',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LK, K, 1, 1, HEAD, ERR01, LK)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR02)
C
      IF (ERR01 .OR. ERR02) GO TO 10
C
      CALL ERSLF(NMSUB, LHLP, K, HLP, HEAD, ERR03)
C
      IF (ERR03) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
      CALL HPFLT (HLP, K, HHP)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   32H       CALL HPCOEF (HLP, K, HHP))
      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
      REAL
     +   HHP(K),HLP(K)
C
C  LOCAL SCALARS
      INTEGER
     +   I,KMID
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL HHP(K)
C        THE ARRAY IN WHICH THE HIGH PASS FILTER COEFFICIENTS
C        WILL BE RETURNED.
C     REAL 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
      DO 20 I = 1, K
         HHP(I) = -HLP(I)
   20 CONTINUE
C
      KMID = (K + 1) / 2
C
      HHP(KMID) = HHP(KMID) + 1.0E0
C
      RETURN
      END
*HSTER
      SUBROUTINE HSTER(NMSUB, Y, N, NCELLS, LDSTAK, YLB, YUB, IERR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE CHECKS INPUT PARAMETERS TO THE USER
C     CALLABLE MEMBERS OF THE HIST FAMILY OF ROUTINES
C     FOR ERRORS AND REPORTS ANY THAT IT FINDS, BESIDES
C     RETURNING A FLAG INDICATING THAT ERRORS HAVE BEEN
C     FOUND.
C
C     WRITTEN BY - JOHN E. KOONTZ, JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YLB,YUB
      INTEGER
     +   IERR,LDSTAK,N,NCELLS
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   LDSMIN,NV
      LOGICAL
     +   HEAD,IER1,IER2,IER3,IER4
C
C  LOCAL ARRAYS
      CHARACTER
     +   LLDS(8)*1,LN(8)*1,LONE(8)*1,LY(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ERVII,LDSCMP
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 IERR
C        OUTPUT PARAMETER.  A FLAG INDICATING WHETHER OR
C        NOT AN ERROR HAS BEEN FOUND.  0 = OK, 1 = ERROR.
C     LOGICAL IER1
C        TRUE IF N .LT. 3
C     LOGICAL IER2
C        TRUE IF LDSTAK .LT. (N + 13)/2.
C     LOGICAL IER3
C        TRUE IF ALL Y VALUES ARE EQUAL.
C     LOGICAL IER4
C        TRUE IF NO DATA WITHIN USER LIMITS
C     INTEGER LDSMIN
C        MINIMUM LENGTH OF FRAMEWORK AREA IN DOUBLE
C        PRECISION ELEMENTS.
C     INTEGER LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF LOCATIONS PROVIDED IN
C        THE FRAMEWORK AREA.
C     CHARACTER*1 LLDS(8), LN(8), LONE(8), LY(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) FO THE VARIALBE(S) CHECKED
C        FOR ERRORS
C     INTEGER N
C        INPUT PARAMETER.  THE NUMBER OF ELEMENTS IN Y.
C     INTEGER NCELLS
C        THE NUMBER OF CELLS IN THE HISTOGRAM.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE
C     INTEGER NV
C        THE NUMBER OF VALUES OUTSIDE USER SUPPLIED LIMITS.
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF N OBSERVATIONS.
C     REAL YLB
C        THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C     REAL YUB
C        THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C
C     INITIALIZE NAME VECTORS
C
      DATA   LLDS(1),  LLDS(2),  LLDS(3),  LLDS(4),  LLDS(5),  LLDS(6),
     +  LLDS(7), LLDS(8) /'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/
      DATA     LN(1),    LN(2),    LN(3),    LN(4),    LN(5),    LN(6),
     +    LN(7),   LN(8) /'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA   LONE(1),  LONE(2),  LONE(3),  LONE(4),  LONE(5),  LONE(6),
     +  LONE(7), LONE(8) /'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/
      DATA     LY(1),    LY(2),    LY(3),    LY(4),    LY(5),    LY(6),
     +    LY(7),   LY(8) /'Y', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
C
C     INITIALIZE ERROR FLAGS
C
      IER1 = .FALSE.
      IER2 = .FALSE.
      IER3 = .FALSE.
      IER4 = .FALSE.
C
      IERR = 0
C
      HEAD = .TRUE.
C
C     CHECK TO SEE THAT THERE IS AT LEAST ONE DATA POINTS.
C
      CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, IER1, LONE)
C
C     CHECK FOR SUFFICIENT WORK AREA
C
      CALL LDSCMP(2, 0, N, 0, 0, 0, 'S', NCELLS, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, IER2, LLDS)
C
C     CHECK WHETHER THERE IS ANY DATA BETWEEN USER SUPPLIED LIMITS
C
      IF ((YLB.LT.YUB) .AND. (N.GE.1))
     +  CALL ERVII (NMSUB, LY, Y, N, YLB, YUB, N-1, HEAD, 1, NV, IER4)
C
C     SEE IF ANY ERRORS WERE FOUND.
C
      IF (IER1 .OR. IER2 .OR. IER3 .OR. IER4) IERR = 1
      RETURN
      END
*HSTMN
      SUBROUTINE HSTMN(Y, N, NCELLS, YLB, YUB, LSORT, YDIST)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN ROUTINE FOR PRODUCING A HISTOGRAM
C
C     ORIGINAL VERSION ADAPTED FROM AN EARLY VERSION OF MINITAB.
C
C     ADAPTED BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YLB,YUB
      INTEGER
     +   N,NCELLS
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(N),YDIST(NCELLS)
      INTEGER
     +   LSORT(N)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,B1SQRT,B2,CFRACT,CFRCTM,CNTMX,FRACT,P,SCALE,SUM1,SUM2,
     +   SUM3,SUMD2,SUMD3,SUMD4,SUMDA,SUMT1,TEMP,WIDTH,XN,XNN,YINTMP,
     +   YMAX,YMDDSD,YMEAN,YMEANT,YMED,YMIDRG,YMIN,YRANGE,YSD,YVAR
      INTEGER
     +   I,IFLAG,IPRT,J,MID,NHIGH,NLOW,NOBS,NUM,NUMS
      CHARACTER
     +   IPLUS*1
C
C  LOCAL ARRAYS
      REAL
     +   A(6)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GENI,IPRINT,SRTIR,SRTRI,STAT1,SUMBS,SUMDS,SUMSS,SUMTS,
     +   VERSP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,INT,MAX,MOD,NINT,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL A(6)
C        A VECTOR USED FOR PRINTING THE HISTOGRAM SCALE.
C     REAL ALPHA
C        THE PERCENTAGE TO BE TRIMMED OFF EACH END OF Y FOR THE
C        TRIMMED MEANS CALCULATIONS.
C     REAL B1SQRT
C        BETA ONE  -  A MEASURE OF SKEWNESS
C     REAL B2
C        BETA TWO  -  A MEASURE OF KURTOSIS
C     REAL CFRACT
C        THE CUMULATIVE DISTRIBUTION
C     REAL CFRCTM
C        THE REVERSE CUMULATIVE DISTRIBUTION
C     REAL CNTMX
C        THE SIZE OF THE LARGEST CELL COUNT
C     REAL FRACT
C        THE FRACTION OF THE OBSERVATIONS IN A GIVEN CELL
C     INTEGER I
C        AN INDEX
C     INTEGER IFLAG
C        IF 1, THEN MORE THAN 50 OBS. FELL IN A SINGLE CELL,
C        AND A SCALED HISTOGRAM WILL BE PROVIDED.
C     CHARACTER*1 IPLUS
C        THE CHARACTER +
C     INTEGER IPRT
C        THE NUMBER OF THE STANDARD OUTPUT UNIT.
C     INTEGER J
C        AN INDEX.
C     INTEGER LSORT(N)
C        THE PERMUTATION VECTOR.
C     INTEGER MID
C        THE INDEX OF THE (AN) ELEMENT OF Y CLOSEST TO ZERO, WHEN
C        Y HAS BEEN SORTED.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y.
C     INTEGER NCELLS
C        THE NUMBER OF CELLS IN THE FREQUENCY DISTRIBUTION.
C     INTEGER NHIGH
C        THE INDEX OF THE LARGEST VALUE IN THE SORTED ARRAY
C        TO BE USED IN THE HISTOGRAM
C     INTEGER NLOW
C        THE INDEX OF THE SMALLEST VALUE IN THE SORTED ARRAY
C        TO BE USED IN THE HISTOGRAM
C     INTEGER NOBS
C        THE NUMBER OF OBSERVATIONS ACTUALLY USED IN THE HISTOGRAM
C     INTEGER NUM
C        THE CELL COUNT
C     INTEGER NUMS
C        THE SCALED CELL COUNT
C     REAL P
C        A VARIABLE USED TO DETERMINE THE SCALE
C     REAL SCALE
C        THE PRINTED INCREMENT ON THE HISTOGRAM SCALE
C     REAL SUMDA
C        THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN.
C     REAL SUMD2
C        THE SUM OF THE SQUARES OF THE DIFFERENCES.
C     REAL SUMD3
C        THE SUM OF THE CUBES OF THE DIFFERENCES.
C     REAL SUMD4
C        THE SUM OF THE 4TH POWERS OF THE DIFFERENCES.
C     REAL SUMT1
C        THE SUM OF THE ALPHA TRIMMED ARRAY Y.
C     REAL SUM1, SUM2, SUM3
C        VARIOUS SUMS OF THE DATA.
C     REAL TEMP
C        A TEMPORARY STORAGE VARIABLE
C     REAL WIDTH
C        THE WIDTH OF A CELL
C     REAL XN
C        THE FOATING POINT REPRESENTATION OF N
C     REAL XNN
C        THE UNROUNDED NUMBER OF PLOTTING POSISTIONS ON A SCALES
C        HISTOGRAM
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF DATA POINTS ON WHICH
C        THE STATISTICS ARE COMPUTED.  Y IS SORTED, BUT RESTORED
C        TO ITS ORIGINAL ORDER AFTERWARDS.
C     REAL YDIST(NCELLS)
C        THE FREQUENCY DISTRIBUTION USED TO CREATE THE HISTOGRAM.
C     REAL YINTMP
C        THE MIDPOINT OF THE ITH CELL
C     REAL YLB
C        THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C     REAL YMAX
C        THE HISTOGRAM UPPER BOUND USED
C     REAL YMDDSD
C        THE MEAN ABSOLUTE DEVIATION / THE STANDARD DEVIATION
C     REAL YMEAN, YMEANT
C        THE MEAN OF THE OBSERVATIONS USED IN THE HISTOGRAM
C     REAL YMED
C        THE MEDIAN OF THE OBSERVATIONS USED IN THE HISTOGRAM
C     REAL YMIDRG
C        THE MID RANGE OF THE OBSERVATIONS USED IN THE HISTOGRAM
C     REAL YMIN
C        THE HISTOGRAM LOWER BOUND USED.
C     REAL YRANGE
C        THE RANGE OF THE OBSERVATIONS USED IN THE HISTOGRAM
C     REAL YSD
C        THE STANDARD DEVIATION OF THE OBSERVATIONS USED IN THE
C        HISTOGRAM.
C     REAL YUB
C        THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM.
C     REAL YVAR
C        THE VARIANCE OF THE OBSERVATIONS.
C
      DATA IPLUS /'+'/
      DATA ALPHA/0.25E0/
C
      CALL IPRINT(IPRT)
C
C     SORT DATA
C
      CALL GENI(LSORT, N, 1, 1)
      CALL SRTIR(LSORT, N, Y)
C
C     FIX UPPER AND LOWER BOUNDS.
C
      NLOW = 1
      NHIGH = N
      IF (YLB.EQ.YUB) GO TO 50
C
C     FIND INDEX OF THE FIRST VALUE OF Y .GE. YLB
C
      DO 20 I=1,N
         IF (Y(I).LT.YLB) GO TO 20
         NLOW = I
         GO TO 30
   20 CONTINUE
C
C     FIND INDEX OF THE LAST VALUE OF Y .LE. YUB
C
   30 DO 40 I=1,N
         J = N - I + 1
         IF (Y(J).GT.YUB) GO TO 40
         NHIGH = J
         GO TO 50
   40 CONTINUE
   50 CONTINUE
      XN = NHIGH-NLOW+1
      NOBS = NHIGH - NLOW + 1
C
C     COMPUTE MEDIAN, EXTREMA, MID-RANGE, RANGE AND FREQUENCY
C     DISTRIBUTION FOR NCELLS CELLS
C
      CALL STAT1(Y(NLOW), NOBS, YMED, YMIN, YMAX, YMIDRG, YRANGE,
     +   NCELLS, YLB, YUB, YDIST)
C
      IF (YLB.GE.YUB) GO TO 55
C
      YMIN = YLB
      YMAX = YUB
C
   55 CONTINUE
C
C     COMPUTE MEAN, TRIMMED MEAN, STANDARD DEVIATION,
C     MEAN DEVIATION/STANDARD DEVIATION, BETA ONE, AND BETA TWO
C
      CALL SUMBS(Y, N, NLOW, MID, NHIGH)
      CALL SUMSS(Y, N, NLOW, MID, NHIGH, SUM1, SUM2, SUM3, YMEAN)
      CALL SUMTS(Y(NLOW), NOBS, ALPHA, SUMT1, YMEANT)
      CALL SUMDS(Y, N, NLOW, MID, NHIGH, YMEAN, SUMDA, SUMD2, SUMD3,
     +   SUMD4)
C
      YVAR = 0.0E0
      YSD = 0.0E0
      B1SQRT = 0.0E0
      B2 = 0.0E0
      YMDDSD = 0.0E0
C
      IF ((SUMD2.LE.0.0E0) .OR. (NOBS.LE.1)) GO TO 60
C
      YVAR = SUMD2/(NOBS-1)
      YSD = SQRT(YVAR)
      B1SQRT = ABS((SUMD3/XN)/((SUMD2/XN)**1.5E0))
      B2 = (SUMD4/XN)/((SUMD2/XN)**2)
      YMDDSD = SUMDA/(YSD*NOBS)
C
   60 CONTINUE
C
C     OUTPUT STATISTICS
C
      CALL VERSP(.TRUE.)
      WRITE (IPRT,1070) N, Y(NLOW), Y(NHIGH), YMIN, YMAX
      WRITE (IPRT,1000)
     +   NCELLS, NOBS, YMEANT, Y(NLOW), YSD, Y(NHIGH), YMDDSD,
     +   YMEAN, B1SQRT, YMED, B2
      WRITE (IPRT,1010)
C
C     CHECK FOR MORE THAN 50 VALUES IN INTERVAL AND FIND MAX. VALUE.
C
      IFLAG = 0
      CNTMX = 0.0E0
      DO 80 I=1,NCELLS
         IF (YDIST(I).GT.CNTMX) CNTMX = YDIST(I)
   80 CONTINUE
      IF (NINT(CNTMX).GT.50) IFLAG = 1
C
C     DETERMINE SCALE.
C
      IF (IFLAG.EQ.0) THEN
         SCALE = 1.0E0
      ELSE
         P = CNTMX/XN
         SCALE = 0.05E0
         IF (P.GT.0.25E0) SCALE = 0.1E0
         IF (P.GT.0.5E0) SCALE = 0.2E0
      END IF
C
C     PRINT COLUMN HEADINGS AND HISTOGRAM SCALE.
C
      IF (IFLAG.EQ.0) WRITE (IPRT,1020)
      IF (IFLAG.NE.0) WRITE (IPRT,1080)
      WRITE (IPRT,1090)
      IF (IFLAG.NE.0) GO TO 100
      WRITE (IPRT,1030) (I,I=10,50,10)
      GO TO 120
  100 A(1) = 0.0E0
      DO 110 I=1,5
         A(I+1) = A(I) + SCALE
  110 CONTINUE
      WRITE (IPRT,1040) (A(I),I=1,6)
  120 WRITE (IPRT,1050)
      CFRACT = 0.0E0
      CFRCTM = 1.0E0
      TEMP = 0.0E0
      WIDTH = (YMAX-YMIN)/NCELLS
      YINTMP = YMIN
      YINTMP = YINTMP - WIDTH/2.0E0
      DO 150 I=1,NCELLS
         NUM = INT(YDIST(I)+0.5E0)
         IF (MOD(NCELLS,2).EQ.1 .AND. I.EQ.NCELLS/2+1
     +       .AND. YMIN.EQ.(-YMAX)) THEN
            YINTMP = 0.0E0
         ELSE
            YINTMP = YINTMP + WIDTH
         END IF
         FRACT = YDIST(I)/XN
         CFRACT = CFRACT + FRACT
         CFRCTM = 1.0E0 - TEMP
         TEMP = CFRACT
         IF (NUM.LE.0) THEN
           WRITE (IPRT,1060) YINTMP, CFRACT, CFRCTM, FRACT, NUM
         ELSE
           IF (IFLAG.EQ.0) THEN
             NUMS = NUM
           ELSE
             XNN = FRACT*10.0E0/SCALE
             NUMS = INT(XNN)
             NUMS = MAX(1, NUMS + INT(XNN-NUMS+0.5E0))
           END IF
           WRITE (IPRT,1060) YINTMP, CFRACT, CFRCTM, FRACT,
     +        NUM, (IPLUS,J=1,NUMS)
         END IF
  150 CONTINUE
C
C     RESTORE DATA TO ORIGINAL ORDER
C
      CALL SRTRI(Y, N, LSORT)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(/26H NUMBER OF CELLS        = , I15/
     +        26H OBSERVATIONS USED      = , I15, 11X,
     +              22H25 PCT TRIMMED MEAN = , 1PE15.8/
     +        26H MIN. OBSERVATION USED  = , E15.8, 11X,
     +              22HSTANDARD DEVIATION  = , E15.8/
     +        26H MAX. OBSERVATION USED  = , E15.8, 11X,
     +              22HMEAN DEV./STD. DEV. = , E15.8/
     +        26H MEAN VALUE             = , E15.8, 11X,
     +              22HSQRT(BETA ONE)      = , E15.8/
     +        26H MEDIAN VALUE           = , E15.8, 11X,
     +              22HBETA TWO            = , E15.8)
 1010 FORMAT(//44H FOR A NORMAL DISTRIBUTION, THE VALUES (MEAN,
     +   56H DEVIATION/STANDARD DEVIATION), SQRT(BETA ONE), AND BETA,
     +   22H TWO ARE APPROXIMATELY/
     +   ' 0.8, 0.0 AND 3.0, RESPECTIVELY.  TO TEST THE ',
     +   59HNULL HYPOTHESIS OF NORMALITY, SEE TABLES OF CRITICAL VALUES,
     +   13H PP. 207-208,/  22H BIOMETRIKA TABLES FOR,
     +   58H STATISTICIANS, VOL. 1.  SEE PP. 67-68 FOR A DISCUSSION OF,
     +   13H THESE TESTS.)
 1020 FORMAT(///5X,39HINTERVAL     CUM.   1-CUM.   CELL   NO.,19X,
     + 22HNUMBER OF OBSERVATIONS)
 1030 FORMAT('+',47X,1H0,8X,5(I2,8X))
 1040 FORMAT('+',46X,6(F4.2,6X))
 1050 FORMAT(4X,42('-'),2X,'+',5(10H---------+))
 1060 FORMAT(3X,1PE13.6,2X,2(0PF5.3,3X),F5.3,1X,I5,4X,50A1)
 1070 FORMAT (10H HISTOGRAM//
     +        26H NUMBER OF OBSERVATIONS = , I15/
     +        26H MINIMUM OBSERVATION    = , 1PE15.8/
     +        26H MAXIMUM OBSERVATION    = , E15.8//
     +        26H HISTOGRAM LOWER BOUND  = , E15.8/
     +        26H HISTOGRAM UPPER BOUND  = , E15.8)
 1080 FORMAT(///5X,39HINTERVAL     CUM.   1-CUM.   CELL   NO.,23X,
     + 13HCELL FRACTION)
 1090 FORMAT(5X,41HMID POINT   FRACT.  FRACT.  FRACT.  OBS. )
      END
      INTEGER FUNCTION I8SAVE(ISW,IVALUE,SET)
C
C  IF (ISW = 1) I8SAVE RETURNS THE CURRENT ERROR NUMBER AND
C               SETS IT TO IVALUE IF SET = .TRUE. .
C
C  IF (ISW = 2) I8SAVE RETURNS THE CURRENT RECOVERY SWITCH AND
C               SETS IT TO IVALUE IF SET = .TRUE. .
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER ISW,IVALUE
      LOGICAL SET
C
C  LOCAL SCALARS
      INTEGER LERROR,LRECOV
C
C  LOCAL ARRAYS
      INTEGER IPARAM(2)
C
C  EQUIVALENCES
      EQUIVALENCE (IPARAM(1),LERROR), (IPARAM(2),LRECOV)
C
C
C  START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF.
C
      DATA LERROR/0/ , LRECOV/2/
C
      I8SAVE=IPARAM(ISW)
      IF (SET) IPARAM(ISW)=IVALUE
C
      RETURN
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
      ICNTI = 0
      DO 10 J = 1, NIV
         IF (IV(J) .EQ. I) ICNTI = ICNTI + 1
   10 CONTINUE
      RETURN
      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 SCOPY,
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
      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
*IDAMAX
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C
C     FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX.
C     IDAMAX =  FIRST I, I = 1 TO N, TO MINIMIZE  ABS(DX(1-INCX+I*INCX))
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER INCX,N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION DX(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION DMAX,XMAG
      INTEGER I,II,NS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC DABS
C
      IDAMAX = 0
      IF(N.LE.0) RETURN
      IDAMAX = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      DMAX = DABS(DX(1))
      NS = N*INCX
      II = 1
          DO 10 I = 1,NS,INCX
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 5
          IDAMAX = II
          DMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 30
          IDAMAX = I
          DMAX = XMAG
   30 CONTINUE
      RETURN
      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
      INTEGER
     +   I1MACH
      EXTERNAL I1MACH
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
*INITDS
      INTEGER FUNCTION INITDS (DOS, NOS, ETA)
C
C INITIALIZE THE DOUBLE PRECISION ORTHOGONAL SERIES DOS SO THAT INITDS
C IS THE NUMBER OF TERMS NEEDED TO INSURE THE ERROR IS NO LARGER THAN
C ETA.  ORDINARILY ETA WILL BE CHOSEN TO BE ONE-TENTH MACHINE PRECISION.
C
C             INPUT ARGUMENTS --
C DOS    DBLE PREC ARRAY OF NOS COEFFICIENTS IN AN ORTHOGONAL SERIES.
C NOS    NUMBER OF COEFFICIENTS IN DOS.
C ETA    REQUESTED ACCURACY OF SERIES.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL ETA
      INTEGER NOS
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION DOS(NOS)
C
C  LOCAL SCALARS
      REAL ERR
      INTEGER I,II
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SNGL
C
C
      IF (NOS.LT.1) CALL XERROR (
     1  'INITDS  NUMBER OF COEFFICIENTS LT 1', 35, 2, 2)
C
      ERR = 0.0
      DO 10 II=1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(SNGL(DOS(I)))
        IF (ERR.GT.ETA) GO TO 20
 10   CONTINUE
C
 20   IF (I.EQ.NOS) CALL XERROR ('INITDS  ETA MAY BE TOO SMALL', 28,
     1  1, 2)
      INITDS = I
C
      RETURN
      END
*INITS
      INTEGER FUNCTION INITS (OS, NOS, ETA)
C APRIL 1977 VERSION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C INITIALIZE THE ORTHOGONAL SERIES SO THAT INITS IS THE NUMBER OF TERMS
C NEEDED TO INSURE THE ERROR IS NO LARGER THAN ETA.  ORDINARILY, ETA
C WILL BE CHOSEN TO BE ONE-TENTH MACHINE PRECISION.
C
C             INPUT ARGUMENTS --
C OS     ARRAY OF NOS COEFFICIENTS IN AN ORTHOGONAL SERIES.
C NOS    NUMBER OF COEFFICIENTS IN OS.
C ETA    REQUESTED ACCURACY OF SERIES.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL ETA
      INTEGER NOS
C
C  ARRAY ARGUMENTS
      REAL OS(NOS)
C
C  LOCAL SCALARS
      REAL ERR
      INTEGER I,II
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C
      IF (NOS.LT.1) CALL XERROR (
     1  'INITS   NUMBER OF COEFFICIENTS LT 1', 35, 2, 2)
C
      ERR = 0.
      DO 10 II=1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(OS(I))
        IF (ERR.GT.ETA) GO TO 20
 10   CONTINUE
C
 20   IF (I.EQ.NOS) CALL XERROR ('INITS   ETA MAY BE TOO SMALL', 28,
     1  1, 2)
      INITS = I
C
      RETURN
      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     INITIALIZATIONS
C
      DATA IEW /15/, IMAXE /7/, IMAXW /132/, IOCPL /15/
C
C     COMMENCE BODY OF ROUTINE
C
      IWIDTH = 132
      INPERL = (MIN(IWIDTH, IMAXW) - IOCPL)/IEW
      INPERL = MIN(INPERL, IMAXE)
      RETURN
      END
*IPGDV
      SUBROUTINE IPGDV (PER, NF, N, PERI, FREQ, XAXIS, YAXIS, ISYM,
     +   LPCV, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRAL PLOTS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LPCV,N,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),PER(NF),PERI(NF),XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
C
C  LOCAL SCALARS
      INTEGER
     +   ISPCER,NPTS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPGMN,IPGORD,IPGOUT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FREQ(NF)
C        THE ARRAY IN WHICH THE FREQUENCIES AT WHICH THE PERIODOGRAM
C        WAS ESTIMATED ARE STORED.
C     INTEGER ISPCER
C        AN ERROR INDICATOR FOR THE INTEGRATED PERIODOGRAM COMPUTATIONS.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER N
C        THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH
C        THE PERIODOGRAM WAS COMPUTED.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .GE.  1, THE OUTPUT CONSISTS OF A PAGE PLOT.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES
C        ARE ESTIMATED.
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     REAL PER(NF)
C        THE RAW PERIODOGRAM.
C     REAL PERI(NF)
C        THE ARRAY CONTAINING THE INTEGRATED PERIODOGRAM VALUES.
C     REAL XAXIS(LPCV), YAXIS(LPCV)
C        THE X, Y CO-ORDINATES FOR THE SPECTRAL PLOTS.
C
C     COMPUTE THE INTEGRATED PERIODOGRAM
C
      CALL IPGMN(PER, NF, PERI, ISPCER)
C
      IF (ISPCER .NE. 0) GO TO 10
C
      IF (NPRT .EQ. 0) RETURN
C
C     SET CO-ORDINATES FOR THE INTEGRATED PERIODOGRAM
C
      CALL IPGORD(PERI, NF, N, FREQ, XAXIS, YAXIS, ISYM, NPTS, LPCV)
C
C     PLOT THE INTEGRATED PERIODOGRAM
C
   10 CALL IPGOUT (XAXIS, YAXIS, ISYM, NPTS, LPCV, ISPCER)
C
      RETURN
C
      END
*IPGM
      SUBROUTINE IPGM (YFFT, N, LYFFT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING
C     THE INTEGRATED PERIODOGRAM OF A SERIES (SHORT CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LDSTAK,LYFFT,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   FREQ,IEXTND,IPRT,ISYM,LDSMIN,LPCV,NALL0,NF,NFFT,NPRT,
     +   XAXIS,YAXIS
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   LLDS(8)*1,LLYFFT(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CNTR,EISGE,IPGDV,IPRINT,LDSCMP,PGMMN,SETESL,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     INTEGER FREQ
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE
C        INTEGRATED SPECTRUM VALUES ARE STORED.
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IEXTND
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO
C        (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE
C        USED TO EXTEND THE SERIES.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     CHARACTER*1 LLDS(8), LLYFFT(8), LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE
C        TIME OF THIS CALL.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .GE.  1, THE OUTPUT CONSISTS OF A PAGE PLOT.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'I',       'P',       'G',       'M',       ' ',       ' '/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     +  LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     +  LLYFFT(6), LLYFFT(7), LLYFFT(8)
     +  /'L','Y','F','F','T',' ',' ',' '/
      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, 17, 1, HEAD, ERR01, LN)
      IF (ERR01) GO TO 5
C
C     SET LENGTH OF EXTENDED SERIES
C
      CALL SETESL(N, 2, NFFT)
      NF = NFFT/2
C
      CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR02, LLYFFT)
C
      CALL LDSCMP(3, 0, NF+103, 0, 0, 0, 'S', 2*NFFT+206, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 5
      GO TO 10
C
    5 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET THE SIZE OF THE WORK AREA
C
      CALL STKSET(LDSTAK, 4)
C
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LPCV = NF + 103
      NPRT = 1
C
C     CENTER THE SERIES
C
      CALL CNTR(YFFT, N, YFFT)
      IEXTND = 0
C
C     SUBDIVIDE THE STACK.
C
      ISYM = STKGET(LPCV, 2)
      XAXIS = STKGET(LPCV, 3)
      YAXIS = STKGET(LPCV, 3)
C
      FREQ = XAXIS
C
C     COMPUTE THE RAW PERIODOGRAM.
C
      CALL PGMMN (YFFT, N, NFFT, IEXTND, NF, YFFT, LYFFT, RSTAK(YAXIS),
     +   RSTAK(FREQ), LPCV, 0, NMSUB)
C
C     CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED
C     PERIODOGRAM.
C
      CALL IPGDV (YFFT, NF, N, YFFT, RSTAK(FREQ), RSTAK(XAXIS),
     +   RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL IPGM (YFFT, N, LYFFT, LDSTAK)')
      END
*IPGMN
      SUBROUTINE IPGMN (PER, NF, PERI, ISPCER)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE INTEGRATED PERIODOGRAM.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   ISPCER,NF
C
C  ARRAY ARGUMENTS
      REAL
     +   PER(NF),PERI(NF)
C
C  LOCAL SCALARS
      REAL
     +   SM
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER ISPCER
C        AN ERROR INDICATOR FOR THE INTEGRATED PERIODOGRAM COMPUTATIONS.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        COMPUTED.
C     REAL PER(NF)
C        THE RAW PERIODOGRAM.
C     REAL PERI(NF)
C        THE ARRAY WHICH CONTAINS THE INTEGRATED PERIODOGRAM.
C     REAL SM
C        A VALUE USED TO COMPUTE THE INTEGRATED PERIODOGRAM ESTIMATES.
C
C
      SM = 0.0E0
C
      DO 30 I = 1, NF
         SM = SM + PER(I)
         PERI(I) = SM
   30 CONTINUE
C
      ISPCER = 1
      IF (SM .EQ. 0.0E0) RETURN
C
      ISPCER = 0
C
      DO 40 I = 1, NF
         PERI(I) = PERI(I)/SM
   40 CONTINUE
C
      RETURN
      END
*IPGMP
      SUBROUTINE IPGMP (PER, FREQ, NF, N, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING
C     THE INTEGRATED PERIODOGRAM OF A SERIES (SHORT CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LDSTAK,N,NF
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),PER(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISYM,LDSMIN,LPCV,NALL0,NPRT,PERI,XAXIS,YAXIS
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   LLDS(8)*1,LN(8)*1,LNF(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,IPGDV,IPRINT,LDSCMP,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FREQ(NF)
C        THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE
C        INTEGRATED SPECTRUM VALUES ARE STORED.
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER ISYM
C        ...
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     CHARACTER*1 LLDS(8), LN(8), LNF(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER LPCV
C        ...
C     INTEGER N
C        THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH
C        THE PERIODOGRAM WAS COMPUTED.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE
C        TIME OF THIS CALL.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        TO BE COMPUTED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .GE.  1, THE OUTPUT CONSISTS OF A PAGE PLOT.
C     REAL PER(NF)
C        THE RAW PERIODOGRAM.
C     INTEGER PERI
C        THE STARTING LOCATION IN THE STACK FOR
C        THE VECTOR CONTAINING THE INTEGRATED PERIODOGRAM.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'I',       'P',       'G',       'M',       'P',       ' '/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     +  LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8)
     + /'N',' ',' ',' ',' ',' ',' ',' '/
      DATA
     + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8)
     + /'N','F',' ',' ',' ',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN)
C
      CALL EISGE(NMSUB, LNF, NF, (N+2)/2, 1, HEAD, ERR02, LNF)
C
      IF (ERR01) GO TO 5
C
      CALL LDSCMP(4, 0, NF+103, 0, 0, 0, 'S', 3*NF+206, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS)
C
      IF (ERR02 .OR. ERR03) GO TO 5
      GO TO 10
C
    5 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET THE SIZE OF THE WORK AREA
C
      CALL STKSET(LDSTAK, 4)
C
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LPCV = NF + 103
      NPRT = 1
C
C     SUBDIVIDE THE STACK.
C
      ISYM = STKGET(LPCV, 2)
      PERI = STKGET(NF, 3)
      XAXIS = STKGET(LPCV, 3)
      YAXIS = STKGET(LPCV, 3)
C
C     CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED
C     PERIODOGRAM.
C
      CALL IPGDV (PER, NF, N, RSTAK(PERI), FREQ, RSTAK(XAXIS),
     +   RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL IPGMP (PER, FREQ, NF, N, LDSTAK)')
      END
*IPGMPS
      SUBROUTINE IPGMPS (PER, FREQ, NF, N, LDSTAK, PERI, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING
C     THE INTEGRATED PERIODOGRAM OF A SERIES (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,N,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),PER(*),PERI(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISYM,LDSMIN,LPCV,NALL0,XAXIS,YAXIS
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   LLDS(8)*1,LN(8)*1,LNF(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,IPGDV,IPRINT,LDSCMP,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FREQ(NF)
C        THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE
C        INTEGRATED SPECTRUM VALUES ARE STORED.
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     CHARACTER*1 LLDS(8), LN(8), LNF(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER N
C        THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH
C        THE PERIODOGRAM WAS COMPUTED.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE
C        TIME OF THIS CALL.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        COMPUTED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .GE.  1, THE OUTPUT CONSISTS OF A PAGE PLOT.
C     REAL PER(NF)
C        THE INTEGRATED PERIODOGRAM.
C     REAL PERI(NF)
C        THE VECTOR IN WHICH THE INTEGRATED PERIODOGRAM IS STORED.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'I',       'P',       'G',       'M',       'P',       'S'/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     +  LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8)
     + /'N',' ',' ',' ',' ',' ',' ',' '/
      DATA
     + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8)
     + /'N','F',' ',' ',' ',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN)
C
      CALL EISGE(NMSUB, LNF, NF, (N+2)/2, 1, HEAD, ERR02, LNF)
C
      IF (ERR01) GO TO 5
C
      IF (NPRT .EQ. 0) THEN
        LDSMIN = 0
      ELSE
        CALL LDSCMP(3, 0, NF+103, 0, 0, 0, 'S', 2*NF+206, LDSMIN)
      END IF
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS)
C
      IF (ERR02 .OR. ERR03) GO TO 5
      GO TO 10
C
    5 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET THE SIZE OF THE WORK AREA
C
      CALL STKSET(LDSTAK, 4)
C
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LPCV = NF + 103
C
C     SUBDIVIDE THE STACK.
C
      IF (NPRT .EQ. 0) THEN
         ISYM = 1
         XAXIS = 1
         YAXIS = 1
      ELSE
         ISYM = STKGET(LPCV, 2)
         XAXIS = STKGET(LPCV, 3)
         YAXIS = STKGET(LPCV, 3)
      END IF
C
C     CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED
C     PERIODOGRAM.
C
      CALL IPGDV (PER, NF, N, PERI, FREQ, RSTAK(XAXIS),
     +   RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL IPGMPS (PER, FREQ, NF, N, LDSTAK, PERI, NPRT)')
      END
*IPGMS
      SUBROUTINE IPGMS (YFFT, N, LYFFT, LDSTAK, NF, PERI, LPERI, FREQ,
     +   LFREQ, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING
C     THE INTEGRATED PERIODOGRAM OF A SERIES (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,LFREQ,LPERI,LYFFT,N,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),PERI(*),YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IEXTND,IPRT,ISYM,LDSMIN,LPCV,NALL0,NFFT,XAXIS,YAXIS
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   LLDS(8)*1,LLFREQ(8)*1,LLPERI(8)*1,LLYFFT(8)*1,LN(8)*1,
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CNTR,EISGE,IPGDV,IPRINT,LDSCMP,PGMMN,SETESL,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL FREQ(LFREQ)
C        THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE
C        INTEGRATED SPECTRUM VALUES ARE STORED.
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IEXTND
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO
C        (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE
C        USED TO EXTEND THE SERIES.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LFREQ
C        THE LENGTH OF THE VECTOR FREQ.
C     CHARACTER*1 LLDS(8), LLFREQ(8), LLPERI(8), LLYFFT(8), LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPERI
C        THE LENGTH OF THE VECTOR PERI.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE
C        TIME OF THIS CALL.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .GE.  1, THE OUTPUT CONSISTS OF A PAGE PLOT.
C     REAL PERI(LPERI)
C        THE VECTOR IN WHICH THE INTEGRATED PERIODOGRAM IS STORED.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'I',       'P',       'G',       'M',       'S',       ' '/
      DATA
     + LLFREQ(1), LLFREQ(2), LLFREQ(3), LLFREQ(4), LLFREQ(5),
     +  LLFREQ(6), LLFREQ(7), LLFREQ(8)
     +  /'L','F','R','E','Q',' ',' ',' '/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     +  LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LLPERI(1), LLPERI(2), LLPERI(3), LLPERI(4), LLPERI(5),
     +  LLPERI(6), LLPERI(7), LLPERI(8)
     +  /'L','P','E','R','I',' ',' ',' '/
      DATA
     + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     +  LLYFFT(6), LLYFFT(7), LLYFFT(8)
     +  /'L','Y','F','F','T',' ',' ',' '/
      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, 17, 1, HEAD, ERR01, LN)
      IF (ERR01) GO TO 5
C
C     SET LENGTH OF EXTENDED SERIES
C
      CALL SETESL(N, 2, NFFT)
      NF = NFFT/2
C
      CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR02, LLYFFT)
C
      CALL EISGE(NMSUB, LLPERI, LPERI, NF, 9, HEAD, ERR03, LLPERI)
C
      CALL EISGE(NMSUB, LLFREQ, LFREQ, NF, 9, HEAD, ERR04, LLFREQ)
C
      IF (NPRT .EQ. 0) THEN
        LDSMIN = 0
      ELSE
        CALL LDSCMP(3, 0, NF+103, 0, 0, 0, 'S', 2*NFFT+206, LDSMIN)
      END IF
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR05, LLDS)
C
      IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05) GO TO 5
      GO TO 10
C
    5 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET THE SIZE OF THE WORK AREA
C
      CALL STKSET(LDSTAK, 4)
C
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LPCV = NF + 103
C
C     CENTER THE SERIES
C
      CALL CNTR(YFFT, N, YFFT)
      IEXTND = 0
C
C     SUBDIVIDE THE STACK.
C
      IF (NPRT .EQ. 0) THEN
         ISYM = 1
         XAXIS = 1
         YAXIS = 1
      ELSE
         ISYM = STKGET(LPCV, 2)
         XAXIS = STKGET(LPCV, 3)
         YAXIS = STKGET(LPCV, 3)
      END IF
C
C     COMPUTE THE RAW PERIODOGRAM.
C
      CALL PGMMN (YFFT, N, NFFT, IEXTND, NF, PERI, LPERI, RSTAK(YAXIS),
     +   FREQ, LFREQ, 0, NMSUB)
C
C     CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED
C     PERIODOGRAM.
C
      CALL IPGDV (PERI, NF, N, PERI, FREQ, RSTAK(XAXIS),
     +   RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL IPGMS (YFFT, N, LYFFT, LDSTAK,'/
     +  '      +            NF, PERI, LPERI, FREQ, LFREQ, NPRT)')
      END
*IPGORD
      SUBROUTINE IPGORD (PERI, NF, N, FREQ, XAXIS, YAXIS, ISYM, NPTS,
     +   LPCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRAL PLOTS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LPCV,N,NF,NPTS
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),PERI(NF),XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
C
C  LOCAL SCALARS
      REAL
     +   CI,CIMID
      INTEGER
     +   I,II,NLIM
C
C  LOCAL ARRAYS
      REAL
     +   S(40)
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD,REAL,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CI, CIMID
C        THE WIDTH AND MIDPOINT OF THE TEST INTERVAL FOR WHITE NOISE.
C     REAL FREQ(NF)
C        THE ARRAY IN WHICH THE FREQUENCIES AT WHICH THE PERIODOGRAM
C        WAS ESTIMATED ARE STORED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER II
C        AN INDEX VARIABLE
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER N
C        THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH
C        THE PERIODOGRAM WAS COMPUTED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES
C        ARE ESTIMATED.
C     INTEGER NLIM
C        THE NUMBER OF POINTS AT WHICH THE WHITE NOISE LIMITS ARE TO
C        PLOTTED.
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     REAL PERI(NF)
C        THE ARRAY CONTAINING THE INTEGRATED PERIODOGRAM VALUES.
C     REAL S(40)
C        VALUES USED TO COMPUTE THE CONFIDENCE LIMITS.
C     REAL XAXIS(LPCV), YAXIS(LPCV)
C        THE X, Y CO-ORDINATES FOR THE SPECTRAL PLOTS.
C
      DATA S(1)/0.975E0/, S(2)/0.842E0/, S(3)/0.708E0/
      DATA S(4)/0.624E0/, S(5)/0.563E0/
      DATA S(6)/0.519E0/, S(7)/0.483E0/, S(8)/0.454E0/
      DATA S(9)/0.430E0/, S(10)/0.409E0/
      DATA S(11)/0.391E0/, S(12)/0.375E0/, S(13)/0.361E0/
      DATA S(14)/0.349E0/, S(15)/0.338E0/
      DATA S(16)/0.327E0/, S(17)/0.318E0/, S(18)/0.309E0/
      DATA S(19)/0.301E0/, S(20)/0.294E0/
      DATA S(21)/0.287E0/, S(22)/0.281E0/, S(23)/0.275E0/
      DATA S(24)/0.269E0/, S(25)/0.264E0/
      DATA S(26)/0.259E0/, S(27)/0.254E0/, S(28)/0.250E0/
      DATA S(29)/0.246E0/, S(30)/0.242E0/
      DATA S(31)/0.238E0/, S(32)/0.234E0/, S(33)/0.231E0/
      DATA S(34)/0.227E0/, S(35)/0.224E0/
      DATA S(36)/0.221E0/, S(37)/0.218E0/, S(38)/0.215E0/
      DATA S(39)/0.213E0/, S(40)/0.210E0/
C
      I = N + MOD(N,2) - 1
C
      IF (I .LE. 40) THEN
         CI = S(I)
      ELSE
         CI = 1.36E0 / SQRT(REAL(I))
      END IF
C
      DO 10 I = 1, NF
         XAXIS(I) = FREQ(I)
         YAXIS(I) = PERI(I)
         ISYM(I) = 1
   10 CONTINUE
C
      NLIM = 101
C
      II = NF
C
      DO 30 I = 1, NLIM, 2
         CIMID = REAL(I-1) / REAL(NLIM-1)
         IF (CIMID - CI .LT. 0.0E0) GO TO 20
         II = II + 1
         XAXIS(II) = CIMID / 2.0E0
         YAXIS(II) = CIMID - CI
         ISYM(II) = 2
   20    IF (CIMID + CI .GT. 1.0E0) GO TO 30
         II = II + 1
         XAXIS(II) = CIMID / 2.0E0
         YAXIS(II) = CIMID + CI
         ISYM(II) = 2
   30 CONTINUE
C
      NPTS = II
C
      RETURN
      END
*IPGOUT
      SUBROUTINE IPGOUT (XAXIS, YAXIS, ISYM, NPTS, LPCV, ISPCER)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES THE INTEGRATED PERIODOGRAM PLOTS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   ISPCER,LPCV,NPTS
C
C  ARRAY ARGUMENTS
      REAL
     +   XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPMN,VERSP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE LOGICAL UNIT NUMBER FOR THE OUTPUT.
C     INTEGER ISPCER
C        AN ERROR INDICATOR FOR THE INTEGRATED PERIODOGRAM COMPUTATIONS.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     REAL XAXIS(LPCV), YAXIS(LPCV)
C        THE X, Y CO-ORDINATES FOR THE SPECTRAL PLOTS.
C
C
C     SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH.
C
      CALL IPRINT (IPRT)
C
      CALL VERSP(.TRUE.)
      WRITE (IPRT, 1000)
C
      IF (ISPCER .EQ. 0) GO TO 5
C
      WRITE (IPRT, 1003)
      RETURN
C
    5 CONTINUE
C
      CALL PPMN (YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, 1, ISYM,
     +  LPCV, 0, -1, 0.0E0, 1.0E0, 0.0E0, 0.5E0, .FALSE., 0)
      WRITE(IPRT, 1002)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(34H INTEGRATED SAMPLE PERIODOGRAM (+)/
     +   5X, 49H WITH 95 PER CENT TEST LIMITS FOR WHITE NOISE (.))
C1001 FORMAT(5H+FREQ/
C    1   7H PERIOD, 9X, 3HINF, 7X, 3H10., 4X, 2H5., 8X, 6H3.3333, 4X,
C    2   3H2.5, 4X, 2H2.)
 1002 FORMAT(5H+FREQ/
     +   7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X,
     +   2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X,
     +   6H2.2222, 4X, 2H2.)
 1003 FORMAT (///42H THE INTEGRATED PERIODOGRAM OF THIS SERIES,
     +   22H COULD NOT BE COMPUTED/
     +   44H BECAUSE THE VARIANCE OF THE SERIES IS ZERO.)
      END
*IPRINT
      SUBROUTINE IPRINT(IPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE LOGICAL UNIT FOR PRINTED OUTPUT.
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
     +   IPRT
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   I1MACH
      EXTERNAL I1MACH
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE UNIT NUMBER FOR OUTPUT.
C
      IPRT = I1MACH(2)
      RETURN
      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
      REAL
     +   D(P),V(*),X(P)
      INTEGER
     +   IV(*)
C
C  LOCAL SCALARS
      REAL
     +   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     REAL 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     REAL 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
      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.0E0/
C
C-----------------------------------------------------------------------
C
      PU = IV(PRUNIT)
      IF (PU .EQ. 0) GO TO 999
      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) WRITE(PU, 1010)
 1010 FORMAT(12H0   IT    NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX)
         IV(NEEDHD) = 0
         WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX)
         GO TO 20
C
C     ***  PRINT LONG SUMMARY LINE  ***
C
 15   IF (IV(NEEDHD) .EQ. 1) WRITE(PU,1015)
 1015 FORMAT(12H0   IT    NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX,
     +       4X,15HMODEL    STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF)
      IV(NEEDHD) = 0
      M = IV(SUSED)
      NRELDF = ZERO
      IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF
      WRITE(PU,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,4E11.3,7A1,4E11.3)
C
 20   GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1
C
 30   WRITE(PU,1030)
 1030 FORMAT(26H0***** X-CONVERGENCE *****)
      GO TO 180
C
 35   WRITE(PU,1035)
 1035 FORMAT(42H0***** RELATIVE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 40   WRITE(PU,1040)
 1040 FORMAT(49H0***** X- AND RELATIVE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 45   WRITE(PU,1045)
 1045 FORMAT(42H0***** ABSOLUTE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 50   WRITE(PU,1050)
 1050 FORMAT(33H0***** SINGULAR CONVERGENCE *****)
      GO TO 180
C
 60   WRITE(PU,1060)
 1060 FORMAT(30H0***** FALSE CONVERGENCE *****)
      GO TO 180
C
 70   WRITE(PU,1070)
 1070 FORMAT(38H0***** FUNCTION EVALUATION LIMIT *****)
      GO TO 180
C
 80   WRITE(PU,1080)
 1080 FORMAT(28H0***** ITERATION LIMIT *****)
      GO TO 180
C
 90   WRITE(PU,1090)
 1090 FORMAT(18H0***** STOPX *****)
      GO TO 180
C
 110  WRITE(PU,1100)
 1100 FORMAT(45H0***** INITIAL SUM OF SQUARES OVERFLOWS *****)
C
      GO TO 150
C
 120  WRITE(PU,1120)
 1120 FORMAT(37H0***** BAD PARAMETERS TO ASSESS *****)
      GO TO 999
C
 130  WRITE(PU,1130)
 1130 FORMAT(36H0***** J COULD NOT BE COMPUTED *****)
      IF (IV(NITER) .GT. 0) GO TO 190
      GO TO 150
C
 140  WRITE(PU,1140) IV1
 1140 FORMAT(14H0***** IV(1) =,I5,6H *****)
      GO TO 999
C
C  ***  INITIAL CALL ON ITSMRY  ***
C
 150  IF (IV(X0PRT) .NE. 0) WRITE(PU,1150) (I, X(I), D(I), I = 1, P)
 1150 FORMAT(23H0    I     INITIAL X(I),7X,4HD(I)//(1X,I5,E17.6,E14.3))
      IF (IV1 .GE. 13) GO TO 999
      IV(NEEDHD) = 0
      IV(PRNTIT) = 0
      IF (OL .EQ. 0) GO TO 999
      IF (OL .LT. 0) WRITE(PU,1010)
      IF (OL .GT. 0) WRITE(PU,1015)
      WRITE(PU,1160) V(F)
 1160 FORMAT(12H0    0     1,E11.3,11X,E11.3)
      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(PU,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF
 1180 FORMAT(9H0FUNCTION,E17.6,8H   RELDX,E20.6/12H FUNC. EVALS,
     +   I8,9X,'GRAD. EVALS',I8/' PRELDF',E19.6,3X,'NPRELDF',E18.6)
C
         IF (IV(NFCOV) .GT. 0) WRITE(PU,1185) IV(NFCOV)
 1185    FORMAT('0',I4,' EXTRA FUNC. EVALS FOR COVARIANCE.')
         IF (IV(NGCOV) .GT. 0) WRITE(PU,1186) IV(NGCOV)
 1186    FORMAT(1X,I4,' EXTRA GRAD. EVALS FOR COVARIANCE.')
C
 190  IF (IV(SOLPRT) .EQ. 0) GO TO 210
         IV(NEEDHD) = 1
         G1 = IV(G)
         WRITE(PU,1190)
 1190 FORMAT('0    I      FINAL X(I)',8X,'D(I)',10X,'G(I)'/)
         DO 200 I = 1, P
              WRITE(PU,1200) I, X(I), D(I), V(G1)
              G1 = G1 + 1
 200          CONTINUE
 1200    FORMAT(1X,I5,E17.6,2E14.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) WRITE(PU,1220)
 1220 FORMAT(43H0++++++ INDEFINITE COVARIANCE MATRIX ++++++)
      IF (-2 .EQ. COV1) WRITE(PU,1225)
 1225 FORMAT(52H0++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++)
      GO TO 999
C
 230  WRITE(PU,1230)
 1230 FORMAT(45H0++++++ COVARIANCE MATRIX NOT COMPUTED ++++++)
      GO TO 999
C
 240  I = ABS(IV(COVREQ))
      IF (I .LE. 1) WRITE(PU,1241)
 1241 FORMAT(48H0COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/)
      IF (I .EQ. 2) WRITE(PU,1242)
 1242 FORMAT(27H0COVARIANCE = SCALE * H**-1/)
      IF (I .GE. 3) WRITE(PU,1243)
 1243 FORMAT(36H0COVARIANCE = SCALE * (J**T * J)**-1/)
      II = COV1 - 1
      IF (OL .LE. 0) GO TO 260
      DO 250 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(PU,1250) I, (V(J), J = I1, II)
 250     CONTINUE
 1250 FORMAT(4H ROW,I3,2X,9E12.4/(9X,9E12.4))
      GO TO 999
C
 260  DO 270 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(PU,1270) I, (V(J), J = I1, II)
 270     CONTINUE
 1270 FORMAT(4H ROW,I3,2X,5E12.4/(9X,5E12.4))
C
 999  RETURN
C  ***  LAST CARD OF ITSMRY FOLLOWS  ***
      END
*J4SAVE
      INTEGER FUNCTION J4SAVE(IWHICH,IVALUE,ISET)
C
C     ABSTRACT
C        J4SAVE SAVES AND RECALLS SEVERAL GLOBAL VARIABLES NEEDED
C        BY THE LIBRARY ERROR HANDLING ROUTINES.
C
C     DESCRIPTION OF PARAMETERS
C      --INPUT--
C        IWHICH - INDEX OF ITEM DESIRED.
C                 = 1 REFERS TO CURRENT ERROR NUMBER.
C                 = 2 REFERS TO CURRENT ERROR CONTROL FLAG.
C                 = 3 REFERS TO CURRENT UNIT NUMBER TO WHICH ERROR
C                     MESSAGES ARE TO BE SENT.  (0 MEANS USE STANDARD.)
C                 = 4 REFERS TO THE MAXIMUM NUMBER OF TIMES ANY
C                     MESSAGE IS TO BE PRINTED (AS SET BY XERMAX).
C                 = 5 REFERS TO THE TOTAL NUMBER OF UNITS TO WHICH
C                     EACH ERROR MESSAGE IS TO BE WRITTEN.
C                 = 6 REFERS TO THE 2ND UNIT FOR ERROR MESSAGES
C                 = 7 REFERS TO THE 3RD UNIT FOR ERROR MESSAGES
C                 = 8 REFERS TO THE 4TH UNIT FOR ERROR MESSAGES
C                 = 9 REFERS TO THE 5TH UNIT FOR ERROR MESSAGES
C        IVALUE - THE VALUE TO BE SET FOR THE IWHICH-TH PARAMETER,
C                 IF ISET IS .TRUE. .
C        ISET   - IF ISET=.TRUE., THE IWHICH-TH PARAMETER WILL BE
C                 GIVEN THE VALUE, IVALUE.  IF ISET=.FALSE., THE
C                 IWHICH-TH PARAMETER WILL BE UNCHANGED, AND IVALUE
C                 IS A DUMMY PARAMETER.
C      --OUTPUT--
C        THE (OLD) VALUE OF THE IWHICH-TH PARAMETER WILL BE RETURNED
C        IN THE FUNCTION VALUE, J4SAVE.
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     ADAPTED FROM BELL LABORATORIES PORT LIBRARY ERROR HANDLER
C     LATEST REVISION ---  23 MAY 1979
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER IVALUE,IWHICH
      LOGICAL ISET
C
C  LOCAL ARRAYS
      INTEGER IPARAM(9)
C
      DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,1,0,10/
      DATA IPARAM(5)/1/
      DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/
      J4SAVE = IPARAM(IWHICH)
      IF (ISET) IPARAM(IWHICH) = IVALUE
      RETURN
      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     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
*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
      REAL
     +   L(*),LIN(*)
C
C  LOCAL SCALARS
      REAL
     +   ONE,T,ZERO
      INTEGER
     +   I,II,IM1,J0,J1,JJ,K,K0,NP1
C
C  ***  PARAMETERS  ***
C
C     INTEGER N
C     REAL 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     REAL ONE, T, ZERO
      DATA ONE/1.0E0/, ZERO/0.0E0/
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
*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
      REAL
     +   L(1),X(N),Y(N)
C
C  LOCAL SCALARS
      REAL
     +   XI,ZERO
      INTEGER
     +   I,I0,II,IJ,IM1,J,NP1
C
      DATA ZERO/0.0E0/
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
*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
      REAL
     +   L(1),X(N),Y(N)
C
C  LOCAL SCALARS
      REAL
     +   T,ZERO
      INTEGER
     +   I,J,K
C
C  EXTERNAL FUNCTIONS
      REAL
     +   DOTPRD
      EXTERNAL DOTPRD
C
      DATA ZERO/0.0E0/
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
*LLCNT
      SUBROUTINE LLCNT(Y, WT, LWT, XM, N, M, IXM, NPAR, RES, LDSTAK,
     +   NPRT, PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV,
     +   IVCV, LLHDR, IFIT, NMSUB, WEIGHT, SAVE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLLING SUBROUTINE FOR LINEAR LEAST
C     SQUARES.
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
      REAL
     +   RSD
      INTEGER
     +   IFIT,IVCV,IXM,LDSTAK,LPAR,LPV,LSDPV,LSDRES,LWT,M,N,NPAR,
     +   NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL LLHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   ACC,C,FC,IFP,NALL0,NDIGIT,NNZW,PAR1,PARI,PVI,RED,RESI,
     +   RSDI,SDPVI,SDRESI,T,VCVI,WTI,WY,XMW
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   IPTOUT(4),ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CPYMSS,LLER,LLSMN,PRTCNT,SCOPY,SETRV,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ACC
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE NUMBER OF ACCURATE DIGITS.
C     INTEGER C
C        *
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER FC
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE ORTHONORMALIZATION MATRIX.
C     INTEGER IERR
C        THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IFIT
C        THE INDICATOR VALUE DESIGNATING WHETHER THE FIT IS OF A
C        GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1).
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IPTOUT(4)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE MATRIX XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     EXTERNAL LLHDR
C        THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
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     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
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     REAL PAR(LPAR)
C        THE PARAMETERS TO BE ESTIMATED.
C     INTEGER PARI
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE PARAMETERS TO BE ESTIMATED.
C     INTEGER PAR1
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE PARAMETERS TO BE ESTIMATED OMMITTING THE LAST
C        INDEPENDENT VARIABLE.
C     REAL PV(LPV)
C        THE PREDICTED VALUES.
C     INTEGER PVI
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE PREDICTED VALUES.
C     INTEGER RED
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE REDUCTION TO THE SUM OF SQUARES DUE TO EACH PARAMETER.
C     REAL RES(N)
C        THE RESIDUALS.
C     INTEGER RESI
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     INTEGER RSDI
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     INTEGER SDPVI
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     INTEGER SDRESI
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE STANDARDIZED RESIDUALS.
C     INTEGER T
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE TRIANGULAR MATRIX FROM THE DECOMPOSITION.
C     REAL VCV(IVCV,NPAR)
C        THE VARIANCE COVARIANCE MATRIX.
C     INTEGER VCVI
C        THE STARTING LOCATION IN THE WORK AREA FOR
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     REAL WT(LWT)
C        THE WEIGHTS.
C     INTEGER WTI
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE WEIGHTS.
C     INTEGER WY
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE VECTOR CONTAINING SQRT(WT)*Y.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C     INTEGER XMW
C        THE STARTING LOCATION IN THE WORK AREA FOR
C        THE MATRIX CONTAINING XM * SQRT(WT).
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      WIDE = .TRUE.
      PAGE = .FALSE.
      NDIGIT = 4
C
      IFP = 3
C
C     SET PRINT CONTROL VALUES
C
      CALL PRTCNT(NPRT, NDIGIT, IPTOUT)
C
C     CHECK FOR ERRORS
C
      CALL LLER(NMSUB, IXM, IVCV, N, NPAR, LPAR, LDSTAK, WT, LWT,
     +   WEIGHT, NNZW, IFIT, SAVE)
      IF (IERR.NE.0) RETURN
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
C     SET UP SUBDIVISION OF WORK AREAS
C
      WTI = STKGET(N,IFP)
      RESI = STKGET(N,IFP)
      RSDI = STKGET(1,IFP)
      PARI = STKGET(NPAR,IFP)
      PVI = STKGET(N,IFP)
      SDPVI = STKGET(N,IFP)
      SDRESI = STKGET(N,IFP)
      VCVI = STKGET(NPAR*NPAR,IFP)
C
      WY = STKGET(N,IFP)
      XMW = STKGET(N*NPAR,IFP)
      RED = STKGET(NPAR,IFP)
      T = STKGET(NPAR*NPAR,IFP)
      PAR1 = STKGET(NPAR,IFP)
      ACC = STKGET(NPAR,IFP)
      C = STKGET(NPAR,IFP)
C
C     EQUIVALENCED LOCATIONS WITHIN SCRAT
C
      FC = XMW
C
C     SET UP WEIGHTS VECTOR
C
      IF (WEIGHT) THEN
         CALL SCOPY(N, WT, 1, RSTAK(WTI), 1)
      ELSE
         CALL SETRV(RSTAK(WTI), N, 1.0E0)
      END IF
C
      CALL LLSMN(Y, XM, RSTAK(WTI), N, M, NPAR, IXM, RSTAK(RESI),
     +   RSTAK(PARI), NNZW, RSTAK(RSDI), RSTAK(PVI), RSTAK(SDPVI),
     +   RSTAK(SDRESI), IPTOUT, RSTAK(WY), RSTAK(XMW), RSTAK(VCVI),
     +   RSTAK(FC), RSTAK(RED), RSTAK(T), RSTAK(PAR1), RSTAK(ACC), IFIT,
     +   WEIGHT, RSTAK(C), LLHDR, PAGE, WIDE)
C
      CALL SCOPY(N, RSTAK(RESI), 1, RES, 1)
C
      IF (SAVE) THEN
         RSD = RSTAK(RSDI)
         CALL SCOPY(NPAR, RSTAK(PARI), 1, PAR, 1)
         CALL SCOPY(N, RSTAK(PVI), 1, PV, 1)
         CALL SCOPY(N, RSTAK(SDPVI), 1, SDPV, 1)
         CALL SCOPY(N, RSTAK(SDRESI), 1, SDRES, 1)
         CALL CPYMSS(NPAR, NPAR, RSTAK(VCVI), NPAR, VCV, IVCV)
      END IF
      CALL STKCLR(NALL0)
C
      IF (IERR.EQ.3) IERR = 2
      IF (IERR.EQ.4) IERR = 3
C
      RETURN
C
      END
*LLCNTG
      SUBROUTINE LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLLING SUBROUTINE FOR GENERAL LINEAR LEAST
C     SQUARES.
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,IXM,LDSTAK,LPAR,LPV,LSDPV,LSDRES,LWT,N,NPAR,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IFIT,M
C
C  EXTERNAL SUBROUTINES
      EXTERNAL LLCNT,LLHDRG
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IFIT
C        THE INDICATOR VALUE DESIGNATING WHETHER THE LLS IS OF A
C        GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1).
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE MATRIX XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     EXTERNAL LLHDRG
C        THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(LPAR)
C        THE PARAMETERS TO BE ESTIMATED.
C     REAL PV(LPV)
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL WT(LWT)
C        THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE).
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      IFIT = 3
      M = NPAR
C
      CALL LLCNT(Y, WT, LWT, XM, N, M, IXM, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   LLHDRG, IFIT, NMSUB, WEIGHT, SAVE)
C
      RETURN
C
      END
*LLCNTP
      SUBROUTINE LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK,
     +   NPRT, PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV,
     +   IVCV, NMSUB, WEIGHT, SAVE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLLING SUBROUTINE FOR POLYNOMIAL LINEAR LEAST
C     SQUARES.
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,LDSTAK,LPAR,LPV,LSDPV,LSDRES,LWT,N,NDEG,NPAR,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IFIT,IXM,M
C
C  EXTERNAL SUBROUTINES
      EXTERNAL LLCNT,LLHDRP
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IFIT
C        THE INDICATOR VALUE DESIGNATING WHETHER THE LLS IS OF A
C        GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1).
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE MATRIX XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     EXTERNAL LLHDRP
C        THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDEG
C        THE DEGREE OF THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(LPAR)
C        THE PARAMETERS TO BE ESTIMATED.
C     REAL PV(LPV)
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL WT(LWT)
C        THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE).
C     REAL XM(N,1)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      IFIT = 1
      NPAR = NDEG + 1
      M = 1
      IXM = N
C
      CALL LLCNT(Y, WT, LWT, XM, N, M, IXM, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   LLHDRP, IFIT, NMSUB, WEIGHT, SAVE)
C
      RETURN
C
      END
*LLER
      SUBROUTINE LLER(NMSUB, IXM, IVCV, N, NPAR, LPAR, LDSTAK, WT, LNWT,
     +   WEIGHT, NNZW, IFIT, SAVE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR THE LINEAR LEAST
C     SQUARES LLSTING 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
      INTEGER
     +   IFIT,IVCV,IXM,LDSTAK,LNWT,LPAR,N,NNZW,NPAR
      LOGICAL
     +   SAVE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   WT(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,LDSMIN,NZW
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERROR(10)
      CHARACTER
     +   LIVCV(8)*1,LIXM(8)*1,LLDS(8)*1,LLPAR(8)*1,LN(8)*1,
     +   LN1(8)*1,LNC(8)*1,LNDEG(8)*1,LNDEG1(8)*1,LNPAR(8)*1,
     +   LONE(8)*1,LWT(8)*1,LZERO(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,ERVWT,LDSCMP
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR(10)
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.
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 IFIT
C        THE INDICATOR VALUE DESIGNATING WHETHER THE LLS IS OF A
C        GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1).
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     CHARACTER*1 LIVCV(8), LIXM(8), LLPAR(8), LLDS(8), LN(8), LNC(8),
C    *   LNDEG(8), LNDEG1(8), LNPAR(8), LN1(8), LONE(8), LWT(8),
C    *   LZERO(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LNWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NZW
C        THE NUMBER OF ZERO WEIGHTS.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(LNWT)
C        THE USER SUPPLIED WEIGHTS.
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 LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6),
     +   LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LLPAR(1), LLPAR(2), LLPAR(3), LLPAR(4), LLPAR(5), LLPAR(6),
     +   LLPAR(7), LLPAR(8) /'L','P','A','R',' ',' ',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LNDEG(1), LNDEG(2), LNDEG(3), LNDEG(4), LNDEG(5), LNDEG(6),
     +   LNDEG(7), LNDEG(8) /'N','D','E','G',' ',' ',' ',' '/
      DATA LNDEG1(1), LNDEG1(2), LNDEG1(3), LNDEG1(4), LNDEG1(5),
     +   LNDEG1(6), LNDEG1(7), LNDEG1(8) /'N','D','E','G','+','1',
     +   ' ',' '/
      DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5),
     +   LNPAR(6), LNPAR(7), LNPAR(8) /'N','P','A','R',' ',' ',' ',
     +   ' '/
      DATA LN1(1), LN1(2), LN1(3), LN1(4), LN1(5), LN1(6),
     +   LN1(7), LN1(8) /'N','-','1',' ',' ',' ',' ',' '/
      DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6),
     +   LONE(7), LONE(8) /'O','N','E',' ',' ',' ',' ',' '/
      DATA LWT(1), LWT(2), LWT(3), LWT(4), LWT(5), LWT(6), LWT(7),
     +   LWT(8) /'W','T',' ',' ',' ',' ',' ',' '/
      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
      IERR = 0
      HEAD = .TRUE.
C
      DO 10 I=1,10
         ERROR(I) = .FALSE.
   10 CONTINUE
C
      IF (IFIT.EQ.1) GO TO 30
C
      DO 20 I = 1, 8
         LNC(I) = LNPAR(I)
   20 CONTINUE
      GO TO 50
C
   30 CONTINUE
      DO 40 I = 1, 8
         LNC(I) = LNDEG1(I)
   40 CONTINUE
C
   50 CONTINUE
C
      CALL EISGE(NMSUB, LN, N, 1, 1, HEAD, ERROR(1), LN)
C
      IF (IFIT.EQ.3)
     +   CALL EISII(NMSUB, LNPAR, NPAR, 1, N, 1, HEAD, ERROR(2), LONE,
     +   LN)
      IF (IFIT.EQ.1)
     +   CALL EISII(NMSUB, LNDEG, NPAR-1, 0, N-1, 1, HEAD, ERROR(2),
     +      LZERO, LN1)
C
      CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(4), LN)
C
      IF (SAVE .AND. (IFIT.EQ.1))
     +   CALL EISGE(NMSUB, LLPAR, LPAR, NPAR, 7, HEAD, ERROR(5), LNDEG1)
C
      IF (SAVE)
     +    CALL EISGE(NMSUB, LIVCV, IVCV, NPAR, 3, HEAD, ERROR(6), LNC)
C
      IF (ERROR(1) .OR. ERROR(2) .OR. ERROR(3)) GO TO 70
C
      NNZW = N
      IF (WEIGHT) CALL ERVWT(NMSUB, LWT, WT, N, NPAR, HEAD, NNZW,
     +   NZW, 2, ERROR(8), LNC)
C
      CALL LDSCMP(15, 0, 0, 0, 0, 0, 'S',
     +            6*N + NPAR*(N+2*NPAR+5) + 1, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(9), LLDS)
C
      DO 60 I=1,10
         IF (ERROR(I)) GO TO 70
   60 CONTINUE
      RETURN
C
   70 CONTINUE
      IERR = 1
      RETURN
C
      END
*LLHDRG
      SUBROUTINE LLHDRG(PAGE, WIDE, ISUBHD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE UNRESTRICTED
C     LINEAR 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  -  DECEMBER 29, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT,1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT,1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT (32H+LINEAR LEAST SQUARES ESTIMATION,
     +  ' WITH USER-SPECIFIED MODEL, CONTINUED')
 1010 FORMAT ('+', 63('*')/
     +   1X, 34H*  LINEAR LEAST SQUARES ESTIMATION,
     +   ' WITH USER-SPECIFIED MODEL  *'/ 1X, 63('*'))
 1020 FORMAT ('1')
 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-'))
      END
*LLHDRP
      SUBROUTINE LLHDRP(PAGE, WIDE, ISUBHD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE POLYNOMIAL LINEAR
C     LEAST SQUARES LLSTING 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
      INTEGER
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT,1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT,1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT (32H+LINEAR LEAST SQUARES ESTIMATION,
     +   33H WITH POLYNOMIAL MODEL, CONTINUED)
 1010 FORMAT ('+', 59('*')/
     +   1X, 34H*  LINEAR LEAST SQUARES ESTIMATION,
     +   25H WITH POLYNOMIAL MODEL  */ 1X,
     +   59('*'))
 1020 FORMAT ('1')
 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-'))
      END
*LLS
      SUBROUTINE LLS(Y, XM, N, IXM, NPAR, RES, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT
C     NO WEIGHTS SPECIFIED
C     NO STORAGE OTHER THAN RESIDUALS
C     FOUR PAGES AUTOMATIC PRINTOUT
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
     +   IXM,LDSTAK,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   RES(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTG
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE MATRIX XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(1)
C        A DUMMY ARRAY FOR
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARDIZED RESIDUALS.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(1)
C        A DUMMY ARRAY FOR
C        THE WEIGHTS.
C     REAL XM(IXM,NPAR)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S',' ',' ',' '/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .FALSE.
      SAVE = .FALSE.
      NPRT = 1111
      LPAR = 1
      LPV = 1
      LSDPV = 1
      LSDRES = 1
      IVCV = 1
      LWT = 1
C
      CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   50H       CALL LLS (Y, XM, N, IXM, NPAR, RES, LSDTAK))
      END
*LLSMN
      SUBROUTINE LLSMN(Y, X, WT, N, M, NPAR, IX, RES, PAR, NNZW,
     +   RSD, PV, SDPV, SDRES, IPTOUT, WY, XW, VCV, FC, RED,
     +   T, PAR1, ACC, IFIT, WEIGHT, C, LLHDR, PAGE, WIDE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN PROGRAM FOR THE LINEAR LEAST SQUARES FITTING
C     PROGRAMS
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
      REAL
     +   RSD
      INTEGER
     +   IFIT,IX,M,N,NNZW,NPAR
      LOGICAL
     +   PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   ACC(NPAR),C(NPAR),FC(N,NPAR),PAR(NPAR),PAR1(NPAR),PV(N),
     +   RED(NPAR),RES(N),SDPV(N),SDRES(N),T(NPAR,NPAR),
     +   VCV(NPAR,NPAR),WT(N),WY(N),X(IX,M),XW(N,NPAR),Y(N)
      INTEGER
     +   IPTOUT(4)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL LLHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   COND,DF,FPLM,FPLRS,FPSPM,PROBT,PROBT1,PX,R2,RATIO,RATIO1,
     +   RSD1,RSS,RSS1,RVAR,RVAR1,SDC,SDC1,SM,TD,WTSQRT,WTSUM,WTYM,YSUM
      INTEGER
     +   I,IDF,IDF1,IER,IPRT,IREFIT,ISUBHD,J,K,NC
      LOGICAL
     +   CONST
C
C  LOCAL ARRAYS
      REAL
     +   DET(2)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFT,R1MACH
      EXTERNAL CDFT,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACCDIG,FITPT1,FITPT2,IPRINT,MGS,OANOVA,VCVOUT
      EXTERNAL STRCO,STRDI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACC(NPAR)
C        THE NUMBER OF ACCURATE DIGITS.
C     REAL C(NPAR)
C        A WORK VECTOR.
C     REAL COND
C        THE CONDITION NUMBER OF THE DESIGN MATRIX.
C     LOGICAL CONST
C        AN INDICATOR VALUE DESIGNATING WHETHER THE FIRST COLUMN OF
C        THE DESIGN MATRIX IS ALL ONES FOR A CONSTANT.
C     REAL DET(2)
C        THE DETERMINENT.
C     REAL DF
C        THE DEGREES OF FREEDOM.
C     REAL FC(N,NPAR)
C        THE ORTHONORMALIZATION MATRIX.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     REAL FPSPM
C        THE FLOATING POINT SMALLEST POSITIVE MAGNITUDE.
C     INTEGER I
C        AN INDEX.
C     INTEGER IDF
C        THE DEGREES OF FREEDOM
C     INTEGER IDF1
C        THE DEGREES OF FREEDOM FOR THE FIT WITHOUT THE LAST INDEPENDENT
C        VARIABLE.
C     INTEGER IER
C        THE ERROR FLAG RETURNED BY THE INVERSION ROUTINES.
C     INTEGER IERR
C        THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IFIT
C        THE INDICATOR VALUE DESIGNATING WHETHER THE FIT IS OF A
C        GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1).
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IPTOUT(4)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER IREFIT
C        AN INDICATOR USED TO DESIGNATE WHETHER THE FIT IS OF THE
C        FULL DESIGN MATRIX (IREFIT=0) OR IS OMITTING THE LAST
C        INDEPENDENT VARIABLE (IREFIT=1).
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IX
C        THE FIRST DIMENSION OF THE MATRIX X.
C     INTEGER J
C        AN INDEX.
C     INTEGER K
C        AN INDEX.
C     EXTERNAL LLHDR
C        THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NC
C        THE NUMBER OF PARAMETERS BEING FIT.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
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     REAL PAR(NPAR)
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PAR1(NPAR)
C        THE PARAMETERS TO BE ESTIMATED OMMITTING THE LAST
C        INDEPENDENT VARIABLE.
C     REAL PROBT
C        ...
C     REAL PROBT1
C        ...
C     REAL PV(N)
C        THE PREDICTED VALUES.
C     REAL PX
C        A WORK VARIABLE.
C     REAL RATIO
C        THE RATIO OF THE PARAMETERS TO THEIR STANDARD DEVIATIONS.
C     REAL RATIO1
C        THE RATIO OF THE PARAMETERS COMPUTED OMITTING THE LAST
C        INDEPENDENT VARIABLE TO THEIR STANDARD DEVIATIONS.
C     REAL RED(NPAR)
C        THE REDUCTION TO THE SUM OF SQUARES DUE TO EACH PARAMETER.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSD1
C        THE RESIDUAL STANDARD DEVIATION FROM THE FIT OMITTING
C        THE LAST INDEPENDENT VARIABLE.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL RSS1
C        THE RESIDUAL SUM OF SQUARES FROM THE FIT OMITTING
C        THE LAST INDEPENDENT VARIABLE.
C     REAL RVAR
C        THE RESIDUAL VARIANCE.
C     REAL RVAR1
C        THE RESIDUAL VARIANCE FROM THE FIT OMITTING
C        THE LAST INDEPENDENT VARIABLE.
C     REAL R2
C        THE MULTIPLE CORRELATION PARAMETER.
C     REAL SDC
C        THE ESTIMATED STANDARD DEVIATIONS OF THE PARAMETERS.
C     REAL SDC1
C        THE ESTIMATED STANDARD DEVIATIONS OF THE PARAMETERS OMITTING
C        THE LAST INDEPENDENT VARIABLE.
C     REAL SDPV(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL SM
C        A WORK VARIABLE.
C     REAL T(NPAR,NPAR)
C        THE TRIANGULAR MATRIX FROM THE DECOMPOSITION.
C     REAL TD
C        A WORK VARIABLE.
C     REAL VCV(NPAR,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     REAL WT(N)
C        THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE).
C     REAL WTSQRT
C        THE SQUARE ROOT OF THE WEIGHT.
C     REAL WTSUM
C        THE SUM OF THE WEIGHTS.
C     REAL WTYM
C        THE SUM OF THE WEIGHTED DEPENDENT VARIABLES.
C     REAL WY(N)
C        THE VECTOR CONTAINING SQRT(WT)*Y.
C     REAL X(IX,M)
C        THE INDEPENDENT VARIABLE.
C     REAL XW(N,NPAR)
C        THE MATRIX CONTAINING X * SQRT(WT).
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C     REAL YSUM
C        THE SUM OF THE WEIGHTED DEPENDENT VARIABLES SQUARED.
C
      CALL IPRINT(IPRT)
C
C     INITIALIZE VARIABLES
C
      FPLM = R1MACH(2)
      FPLRS = R1MACH(4)
      FPSPM = R1MACH(1)
      NC = NPAR
      IDF = NNZW - NC
      DF = IDF
C
      R2 = 0.0
      RVAR1 = 0.0
      RSD1 = 0.0
      J = 0
      IDF1 = 0
      CONST = .FALSE.
C
      YSUM = 0.0E0
      WTSUM = 0.0E0
      DO 10 I=1,N
         IF (WT(I).LE.0.0E0) GO TO 10
         YSUM = YSUM + WT(I)*Y(I)*Y(I)
         WTSUM = WTSUM + WT(I)
   10 CONTINUE
C
C     BEGIN FIT
C
      IREFIT = -1
C
C     IF IREFIT IS EQUAL TO 1 FIT IS OMITTING THE LAST VARIABLE
C
   50 IREFIT = IREFIT + 1
C
C     COMPUTE WORKING VECTORS
C
      WTYM = 0.0E0
      I = 0
      DO 70 K=1,N
         IF (WT(K).LE.0.0E0) GO TO 70
         WTSQRT = SQRT(WT(K))
         I = I + 1
         PX = WTSQRT
         DO 60 J=1,NC
            IF (IFIT.EQ.1 .AND. J.GE.2) PX = PX*X(K,1)
            IF (IFIT.EQ.3) PX = X(K,J)*WTSQRT
            XW(I,J) = PX
   60    CONTINUE
C
C     COMPUTE WY ( WEIGHTS * Y VECTOR )
C
         WY(I) = Y(K)*WTSQRT
         WTYM = WTYM + WT(K)*Y(K)
   70 CONTINUE
      WTYM = WTYM/WTSUM
C
C     COMPUTE ESTIMATED VALUES OF PARAMETERS
C
      IF (IREFIT.EQ.1) GO TO 80
      IER = 0
      CALL MGS(XW, WY, NNZW, NC, PAR, C, T(1,1), T, NPAR, N, IER)
      IF (IER.EQ.0) GO TO 90
      IERR = 3
      ISUBHD = 0
      CALL LLHDR(PAGE, WIDE, ISUBHD)
      WRITE (IPRT,1160)
      WRITE (IPRT,1150)
      RETURN
   80 CONTINUE
      IER = 0
      CALL MGS(XW, WY, NNZW, NC, PAR1, C, T(1,1), T, NPAR, N, IER)
C
C     COMPUTE PREDICTED VALUES (PV) AND RESIDUALS (RES)
C             RESIDUAL SUM OF SQUARES (RSS) AND
C             RESIDUAL STANDARD DEVIATION (RSD) AND
C             SUM OF WEIGHTS (WTSUM) AND
C             RESIDUAL VARAINCE (RVAR)
C
   90 RSS = 0.0E0
      RSS1 = 0.0E0
      DO 120 I=1,N
         SM = 0.0E0
         PX = 1.0E0
         DO 100 J=1,NC
            IF (IFIT.EQ.1 .AND. J.GE.2) PX = PX*X(I,1)
            IF (IFIT.EQ.3) PX = X(I,J)
            IF (IREFIT.EQ.0) SM = SM + PAR(J)*PX
            IF (IREFIT.EQ.1) SM = SM + PAR1(J)*PX
  100    CONTINUE
         IF (IREFIT.EQ.0) THEN
            PV(I) = SM
            RES(I) = Y(I) - PV(I)
            RSS = RSS + RES(I)*WT(I)*RES(I)
         ELSE
            RSS1 = RSS1 + (Y(I)-SM)*WT(I)*(Y(I)-SM)
         END IF
  120 CONTINUE
C
      IF (IREFIT.EQ.0) GO TO 130
      RVAR1 = RSS1/(DF+1.0E0)
      RSD1 = SQRT(RVAR1)
      GO TO 380
  130 RVAR = 0.0E0
      IF (DF.GT.0.0E0) RVAR = RSS/DF
      RSD = SQRT(RVAR)
C
C     COMPUTE MULTIPLE CORRELATION PARAMETER SQUARED (R2)
C
      SM = 0.0E0
      CONST = .TRUE.
      DO 140 I=1,N
         IF ((X(I,1).NE.1.0E0) .AND. (IFIT.EQ.3)) CONST = .FALSE.
         SM = SM + (Y(I)-WTYM)*WT(I)*(Y(I)-WTYM)
  140 CONTINUE
      R2 = 1.0E0
      IF (SM.GT.0.0E0) R2 = 1.0E0-RSS/SM
C
C     CHECK FOR -EXACT- FIT
C
      TD = 0.0E0
      IF (DF.GT.0.0E0) TD = SQRT(RSS)
      IF (YSUM.GT.0.0E0) TD = TD/SQRT(YSUM)
      IF (TD.GT.10.0E0*FPLRS) GO TO 180
C
      IERR = 0
      IF ((IPTOUT(1).EQ.0) .AND. (IPTOUT(2).EQ.0) .AND. (IPTOUT(3).EQ.0)
     +   .AND. (IPTOUT(4).EQ.0)) GO TO 145
      ISUBHD = 0
      CALL LLHDR(PAGE, WIDE, ISUBHD)
      WRITE (IPRT,1180)
      WRITE (IPRT,1020) (I,PAR(I),I=1,NPAR)
C
C     ZERO OUT VCV MATRIX AND SDRES AND SDPV VECTORS
C
  145 CONTINUE
      DO 150 I=1,N
         SDPV(I) = 0.0E0
         SDRES(I) = 0.0E0
  150 CONTINUE
      DO 170 I=1,NPAR
         DO 160 J=1,NPAR
            VCV(I,J) = 0.0E0
  160    CONTINUE
  170 CONTINUE
      RETURN
C
  180 CONTINUE
C
C     COMPUTE ORTHO NORMALIZATION
C
      DO 200 I=1,NC
         T(I,I) = SQRT(T(I,1))
         DO 190 J=I,NC
            IF (I.EQ.J) GO TO 190
            T(I,J) = T(I,J)*T(I,I)
  190    CONTINUE
  200 CONTINUE
C
      CALL STRCO(T, NPAR, NC, COND, C, 1)
      IF (COND.NE.0.0E0) THEN
         COND = 1.0E0/COND
      ELSE
         COND = FPLM
      END IF
      CALL STRDI(T, NPAR, NC, DET, 011, IER)
C
      IF (IER.EQ.0) GO TO 210
      IERR = 3
      ISUBHD = 0
      CALL LLHDR(PAGE, WIDE, ISUBHD)
      WRITE (IPRT,1160)
      WRITE (IPRT,1120)
      RETURN
  210 CONTINUE
      DO 240 I=1,N
         DO 230 J=1,NC
            SM = 0.0E0
            PX = 1.0E0
            DO 220 K=1,J
               IF (IFIT.EQ.1 .AND. K.GE.2) PX = PX*X(I,1)
               IF (IFIT.EQ.3) PX = X(I,K)
               SM = SM + PX*T(K,J)
  220       CONTINUE
            FC(I,J) = SM
  230    CONTINUE
  240 CONTINUE
C
C     COMPUTE REDUCTION TO RSS DUE TO FITTING
C
      DO 260 J=1,NC
         SM = 0.0E0
         DO 250 I=1,N
            SM = SM + (FC(I,J))*WT(I)*Y(I)
  250    CONTINUE
         RED(J) = (SM*SM)
  260 CONTINUE
C
C     COMPUTE ESTIMATED VARIANCE COVARIANCE MATRIX
C
      DO 290 I=1,NC
         DO 280 J=I,NC
            SM = 0.0E0
            DO 270 K=J,NC
               SM = SM + T(I,K)*T(J,K)
  270       CONTINUE
            IF (SQRT(ABS(SM))*SQRT(RVAR).GE.SQRT(FPSPM)) THEN
               VCV(I,J) = SM*RVAR
            ELSE
               VCV(I,J) = 0.0E0
            END IF
            VCV(J,I) = VCV(I,J)
  280    CONTINUE
  290 CONTINUE
C
C     REFIT TO PREDICTED VALUES
C
      I = 0
      DO 310 K=1,N
         IF (WT(K).LE.0.0E0) GO TO 310
         WTSQRT = SQRT(WT(K))
         I = I + 1
         PX = WTSQRT
         DO 300 J=1,NC
            IF (IFIT.EQ.1 .AND. J.GE.2) PX = PX*X(K,1)
            IF (IFIT.EQ.3) PX = X(K,J)*WTSQRT
            XW(I,J) = PX
  300    CONTINUE
         WY(I) = PV(K)*WTSQRT
  310 CONTINUE
C
      IER = 0
      CALL MGS(XW, WY, NNZW, NC, PAR1, C, T(1,1), T, NPAR, N, IER)
C
      CALL ACCDIG(PAR, PAR1, ACC, NC)
C
C     COMPUTE STANDARD DEVIATION OF PREDICTED VALUES (SDPV)
C     AND STANDARDIZED RESIDUALS (SDRES)
C
      DO 360 I=1,N
         SM = 0.0E0
         DO 330 J=1,NC
            SM = 0.0E0
            PX = 1.0E0
            DO 320 K=1,NC
               IF (IFIT.EQ.1 .AND. K.GE.2) PX = PX*X(I,1)
               IF (IFIT.EQ.3) PX = X(I,K)
               SM = SM + PX*VCV(J,K)
  320       CONTINUE
            XW(I,J) = SM
  330    CONTINUE
         SM = 0.0E0
         PX = 1.0E0
         DO 340 K=1,NC
            IF (IFIT.EQ.1 .AND. K.GE.2) PX = PX*X(I,1)
            IF (IFIT.EQ.3) PX = X(I,K)
            SM = SM + XW(I,K)*PX
  340    CONTINUE
         SM = MAX(0.0E0, SM)
         SDPV(I) = SQRT(SM)
         SDRES(I) = FPLM
         IF (WT(I).LE.0.0E0) GO TO 360
         IF ((RVAR/WT(I)-SM).LE.0.0E0) IERR = 4
         IF (RVAR/WT(I)-SM.GT.0.0E0)
     +      SDRES(I) = (RES(I)/SQRT(RVAR/WT(I)-SM))
  360 CONTINUE
C
C     CHECK FOR PRINTED OUTPUT
C
      IF ((IPTOUT(1).EQ.0) .AND. (IPTOUT(2).EQ.0) .AND.
     +   (IPTOUT(3).EQ.0) .AND. (IPTOUT(4).EQ.0)) RETURN
C
C     BEGIN PRINTED OUTPUT
C
      IF (IPTOUT(1).EQ.0) GO TO 370
C
C     PRINT FIRST PAGE OF OUTPUT
C
      ISUBHD = 0
      CALL LLHDR(PAGE, WIDE, ISUBHD)
      CALL FITPT1(N, M, X, Y, PV, SDPV, RES, SDRES, WT, IX, NNZW,
     +   WEIGHT, IPTOUT(1))
C
C     PRINT PLOTS
C
  370 CONTINUE
      IF (IPTOUT(2).EQ.0) GO TO 375
      ISUBHD = 0
      CALL LLHDR(PAGE, WIDE, ISUBHD)
      CALL FITPT2 (SDRES, PV, WT, N, NNZW, WEIGHT, RES, RSS)
C
  375 CONTINUE
      IF (IPTOUT(3).EQ.0) GO TO 376
C
C     PRINT ANALYSIS OF VARIANCE
C
      ISUBHD = 0
      CALL LLHDR(PAGE, WIDE, ISUBHD)
      CALL OANOVA(YSUM, RED, NPAR, RVAR, NNZW, PAR1, IPRT)
C
  376 CONTINUE
      IF (IPTOUT(4).EQ.0) RETURN
C
      IF (NPAR.EQ.1) GO TO 450
      NC = NC - 1
      IDF1 = NNZW - NC
      GO TO 50
  380 CONTINUE
      DO 400 I=1,NC
         T(I,I) = SQRT(T(I,1))
         DO 390 J=I,NC
            IF (I.EQ.J) GO TO 390
            T(I,J) = T(I,J)*T(I,I)
  390    CONTINUE
  400 CONTINUE
C
      CALL STRDI(T, NPAR, NC, DET, 011, IER)
C
      IF (IER.EQ.0) GO TO 420
      WRITE (IPRT,1140)
      DO 410 I=1,NC
         PAR1(I) = 0.0E0
         T(I,I) = 0.0E0
  410 CONTINUE
      GO TO 450
  420 CONTINUE
      DO 440 I=1,NC
         SM = 0.0E0
         DO 430 K=I,NC
            SM = SM + T(I,K)*T(I,K)
  430    CONTINUE
         T(I,I) = SM
  440 CONTINUE
C
C     PRINT PAGE HEADINGS
C
  450 CONTINUE
      ISUBHD = 0
      CALL LLHDR(PAGE, WIDE, ISUBHD)
C
C     PRINT VARIANCE COVARIANCE MATRIX
C
      CALL VCVOUT(NPAR, VCV, NPAR, .TRUE.)
C
      WRITE (IPRT,1030)
      IF (NPAR.GT.1) WRITE (IPRT,1040)
      WRITE (IPRT,1050)
      IF (NPAR.GT.1) WRITE (IPRT,1060)
      WRITE (IPRT, 1170)
      IF (NPAR.GE.2) THEN
         DO 460 I=1,NC
            SDC = SQRT(VCV(I,I))
            RATIO = FPLM
            PROBT = 0.0E0
            IF (SDC.GT.0.0E0) RATIO = PAR(I)/SDC
            IF (SDC.GT.0.0E0)
     +         PROBT = (1.0E0-CDFT(ABS(RATIO), NNZW-NPAR)) * 2.0E0
            SDC1 = SQRT(T(I,I))*SQRT(RVAR1)
            RATIO1 = FPLM
            PROBT1 = 0.0E0
            IF (SDC1.GT.0.0E0) RATIO1 = PAR1(I)/SDC1
            IF (SDC1.GT.0.0E0)
     +         PROBT1 = (1.0E0 - CDFT(ABS(RATIO1), NNZW-NPAR+1)) * 2.0E0
            WRITE (IPRT,1070) I, PAR(I), SDC, RATIO, PROBT, ACC(I),
     +         PAR1(I), SDC1, RATIO1, PROBT1
  460    CONTINUE
      END IF
      SDC = SQRT(VCV(NPAR,NPAR))
      RATIO = FPLM
      PROBT = 0.0E0
      IF (SDC.GT.0.0E0) RATIO = PAR(NPAR)/SDC
      IF (SDC.GT.0.0E0)
     +   PROBT = (1.0E0 - CDFT(ABS(RATIO), NNZW-NPAR)) * 2.0E0
      WRITE (IPRT,1070) NPAR, PAR(NPAR), SDC, RATIO, PROBT, ACC(NPAR)
      IF (NPAR.EQ.1) WRITE (IPRT,1080) RSD
      IF (NPAR.GT.1) WRITE (IPRT,1080) RSD, RSD1
      WRITE (IPRT,1090) NNZW, NPAR, IDF
      IF (NPAR.GT.1) WRITE (IPRT,1100) NNZW, NC, IDF1
      IF (CONST) WRITE (IPRT,1010) R2
      WRITE (IPRT,1000) COND
      WRITE (IPRT,1110)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/29H APPROXIMATE CONDITION NUMBER, 10X, G15.7)
 1010 FORMAT (/44H MULTIPLE CORRELATION COEFFICIENT SQUARED   , F7.4)
 1020 FORMAT (//46H THE VALUES COMPUTED FOR THE PARAMETERS ARE - /(5X,
     +   4HPAR(, I3, 4H) = , G15.7))
 1030 FORMAT (////1X, 25('-'), 1X, 18HESTIMATES FROM FIT, 1X, 24('-'))
 1040 FORMAT ('+', 72X, 4('-'), 1X,
     +   48HESTIMATES FROM FIT OMITTING LAST PREDICTOR VALUE, 1X,
     +   4('-'))
 1050 FORMAT (/2X, 19HESTIMATED PARAMETER, 7X, 9HSD OF PAR, 5X,
     +   8HT(PAR=0), 3X, 7HPROB(T), 2X, 8HACC DIG*)
 1060 FORMAT ('+', 72X, 19HESTIMATED PARAMETER, 7X, 9HSD OF PAR, 5X,
     +   8HT(PAR=0), 3X, 7HPROB(T))
 1070 FORMAT (1X, I3, 2X, G16.9, 3X, G16.9, 2X, G10.4, 1X, F5.3, 2X,
     +   F7.1, 9X, G16.9, 3X, G16.9, 2X, G10.4, 1X, F5.3)
 1080 FORMAT (//1X, 30HRESIDUAL STANDARD DEVIATION   , 9X, G15.7, 56X,
     +   G15.7)
 1090 FORMAT (1X, 27HBASED ON DEGREES OF FREEDOM, 7X, I4, 3H - , I2,
     +   3H = , I4)
 1100 FORMAT ('+', 105X, I4, 3H - , I2, 3H = , I4)
 1110 FORMAT (//52H * THE NUMBER OF CORRECTLY COMPUTED DIGITS IN EACH P,
     +   56HARAMETER USUALLY DIFFERS BY LESS THAN 1 FROM THE VALUE G,
     +   10HIVEN HERE.)
 1120 FORMAT (/47H THE PROGRAM WAS UNABLE TO COMPUTE THE VARIANCE,
     +   19H-COVARIANCE MATRIX./
     +   52H THE DESIGN MATRIX IS EITHER NEARLY SINGULAR OR VERY,
     +   17H ILL CONDITIONED./
     +   29H CHECK YOUR INPUT FOR ERRORS.)
 1140 FORMAT (54H0ESTIMATES FOR THE STANDARD DEVIATION OF THE ESTIMATED,
     +   55HPARAMETERS OMITTING THE LAST INDEPENDENT VARIABLE COULD/
     +   59H NOT BE COMPUTED.  THE ZEROS PRINTED FOR THE ESTIMATES OF T,
     +   50HHE PARAMETERS, THEIR STANDARD DEVIATIONS AND THEIR/
     +   59H RATIOS FOR THE FIT OMITTING THE LAST VARIABLE ARE MEANINGL,
     +   4HESS.)
 1150 FORMAT (/30H THE DESIGN MATRIX IS SINGULAR,
     +   29H TO WITHIN MACHINE PRECISION./
     +   50H CHECK THE DESIGN MATRIX FOR A LINEAR RELATIONSHIP,
     +   29H BETWEEN SOME OF THE COLUMNS.)
 1160 FORMAT (//1X, 11('*')/ 1X, 11H*  ERROR  */ 1X, 11('*'))
 1170 FORMAT (' ')
 1180 FORMAT (/50H THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS,
     +   35H EXACT TO WITHIN MACHINE PRECISION./
     +   38H STATISTICAL ANALYSIS IS NOT POSSIBLE.)
      END
*LLSP
      SUBROUTINE LLSP(Y, XM, N, NDEG, RES, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT
C     NO WEIGHTS SPECIFIED
C     NO STORAGE OTHER THAN RESIDUALS
C     FOUR PAGES AUTOMATIC PRINTOUT
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
     +   LDSTAK,N,NDEG
C
C  ARRAY ARGUMENTS
      REAL
     +   RES(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPAR,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTP
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDEG
C        THE DEGREE OF THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(1)
C        A DUMMY ARRAY FOR
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARDIZED RESIDUALS.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(1)
C        A DUMMY ARRAY FOR
C        THE WEIGHTS.
C     REAL XM(N,1)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S','P',' ',' '/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .FALSE.
      SAVE = .FALSE.
      NPRT = 1111
      LPAR = 1
      LPV = 1
      LSDPV = 1
      LSDRES = 1
      IVCV = 1
      LWT = 1
C
      CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   45H       CALL LLSP (Y, X, N, NDEG, RES, LSDTAK))
      END
*LLSPS
      SUBROUTINE LLSPS(Y, XM, N, NDEG, RES, LDSTAK,
     +   NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV, SDRES, VCV, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT
C     NO WEIGHTS SPECIFIED
C     FULL STORAGE
C     USER CONTROL OF AUTOMATIC PRINTOUT
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,LDSTAK,LPAR,N,NDEG,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LPV,LSDPV,LSDRES,LWT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTP
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDEG
C        THE DEGREE OF THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(LPAR)
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(N)
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL WT(1)
C        THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE).
C     REAL XM(N,1)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S','P','S',' '/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .FALSE.
      SAVE = .TRUE.
      LPV = N
      LSDPV = N
      LSDRES = N
      LWT = 1
C
      CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL LLSPS (Y, X, N, NDEG, RES, LSDTAK,'/
     +   '      +            NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV,'/
     +   '      +            SDRES, VCV, IVCV)')
      END
*LLSPW
      SUBROUTINE LLSPW(Y, WT, XM, N, NDEG, RES, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT
C     USER SUPPLIED WEIGHTS SPECIFIED
C     NO STORAGE OTHER THAN RESIDUALS
C     FOUR PAGES AUTOMATIC PRINTOUT
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
     +   LDSTAK,N,NDEG
C
C  ARRAY ARGUMENTS
      REAL
     +   RES(*),WT(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPAR,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTP
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDEG
C        THE DEGREE OF THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(1)
C        A DUMMY ARRAY FOR
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARDIZED RESIDUALS.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(N)
C        A DUMMY ARRAY FOR
C        THE WEIGHTS.
C     REAL XM(N,1)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S','P','W',' '/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .TRUE.
      SAVE = .FALSE.
      NPRT = 1111
      LPAR = 1
      LPV = 1
      LSDPV = 1
      LSDRES = 1
      IVCV = 1
      LWT = N
C
      CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   50H       CALL LLSPW (Y, WT, X, N, NDEG, RES, LSDTAK))
      END
*LLSPWS
      SUBROUTINE LLSPWS(Y, WT, XM, N, NDEG, RES, LDSTAK,
     +   NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV, SDRES, VCV, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT
C     USER SUPPLIED WEIGHTS SPECIFIED
C     FULL STORAGE
C     USER CONTROL OF AUTOMATIC PRINTOUT
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,LDSTAK,LPAR,N,NDEG,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LPV,LSDPV,LSDRES,LWT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTP
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDEG
C        THE DEGREE OF THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(LPAR)
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(N)
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL WT(N)
C        THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE).
C     REAL XM(N,1)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S','P','W','S'/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .TRUE.
      SAVE = .TRUE.
      LPV = N
      LSDPV = N
      LSDRES = N
      LWT = N
C
      CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL LLSPWS (Y, WT, X, N, NDEG, RES, LSDTAK,'/
     +   '      +             NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV,'/
     +   '      +             SDRES, VCV, IVCV)')
      END
*LLSS
      SUBROUTINE LLSS(Y, XM, N, IXM, NPAR, RES, LDSTAK,
     +   NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT
C     NO WEIGHTS SPECIFIED
C     FULL STORAGE
C     USER CONTROL OF AUTOMATIC PRINTOUT
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,IXM,LDSTAK,N,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LPAR,LPV,LSDPV,LSDRES,LWT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTG
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE MATRIX XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(NPAR)
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(N)
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL WT(1)
C        THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE).
C     REAL XM(IXM,NPAR)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S','S',' ',' '/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .FALSE.
      SAVE = .TRUE.
      LPAR = NPAR
      LPV = N
      LSDPV = N
      LSDRES = N
      LWT = 1
C
      CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL LLSS (Y, XM, N, IXM, NPAR, RES, LSDTAK,'/
     +  '      +           NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV)')
      END
*LLSW
      SUBROUTINE LLSW(Y, WT, XM, N, IXM, NPAR, RES, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT
C     USER SUPPLIED WEIGHTS SPECIFIED
C     NO STORAGE OTHER THAN RESIDUALS
C     FOUR PAGES AUTOMATIC PRINTOUT
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
     +   IXM,LDSTAK,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   RES(*),WT(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTG
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE MATRIX XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(1)
C        A DUMMY ARRAY FOR
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARDIZED RESIDUALS.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(N)
C        A DUMMY ARRAY FOR
C        THE WEIGHTS.
C     REAL XM(IXM,NPAR)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S','W',' ',' '/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .TRUE.
      SAVE = .FALSE.
      NPRT = 1111
      LPAR = 1
      LPV = 1
      LSDPV = 1
      LSDRES = 1
      IVCV = 1
      LWT = N
C
      CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL LLSW (Y, WT, XM, N, IXM, NPAR, RES, LSDTAK)')
      END
*LLSWS
      SUBROUTINE LLSWS(Y, WT, XM, N, IXM, NPAR, RES, LDSTAK,
     +   NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT
C     USER SUPPLIED WEIGHTS SPECIFIED
C     FULL STORAGE
C     USER CONTROL OF AUTOMATIC PRINTOUT
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,IXM,LDSTAK,N,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LPAR,LPV,LSDPV,LSDRES,LWT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LLCNTG
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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 DESIGNATING WHETHER ANY ERRORS WERE
C        DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE MATRIX XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPAR
C        THE ACTUAL LENGTH OF THE VECTOR P.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF
C        PRINTED OUTPUT.
C     REAL PAR(NPAR)
C        THE PARAMETERS  TO BE ESTIMATED.
C     REAL PV(N)
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE).
C     REAL SDPV(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL WT(N)
C        THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE).
C     REAL XM(IXM,NPAR)
C        THE INDEPENDENT VARIABLE.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'L','L','S','W','S',' '/
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      WEIGHT = .TRUE.
      SAVE = .TRUE.
      LPAR = NPAR
      LPV = N
      LSDPV = N
      LSDRES = N
      LWT = N
C
      CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT,
     +   PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV,
     +   NMSUB, WEIGHT, SAVE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL LLSWS (Y, WT, XM, N, IXM, NPAR, RES, LSDTAK,'/
     + '      +            NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV)')
      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
      REAL
     +   D(P),G(P),QTR(P),R(1),STEP(P),V(21),W(1)
      INTEGER
     +   IPIVOT(P)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   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     REAL 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     REAL 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     REAL 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     REAL DOTPRD, V2NORM
C
C  ***  SUBSCRIPTS FOR V  ***
C
C     INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC,
C    1        PHMXFC, PREDUC, RADIUS, RAD0, STPPAR
      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.0E0/, EIGHT/8.0E0/, HALF/0.5E0/, NEGONE/-1.0E0/,
     +     ONE/1.0E0/, P001/1.0E-3/, THREE/3.0E0/, TTOL/2.5E0/,
     +     ZERO/0.0E0/
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.0E0
      PSIFAC = 0.0E0
      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
*LOGLMT
      SUBROUTINE LOGLMT (ILOGY, YMN, YMX, YLABEL, NUMROW, ISTEP, DELY,
     +  YWIDTH, NLABLY, YDMN, YDMX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     ADJUST PLOT LIMITS FOR LOG PLOTS, AND COMPUTE LOG AXIS LABELS
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
      REAL
     +   DELY,YDMN,YDMX,YMN,YMX,YWIDTH
      INTEGER
     +   ILOGY,ISTEP,NLABLY,NUMROW
C
C  ARRAY ARGUMENTS
      REAL
     +   YLABEL(20)
C
C  LOCAL SCALARS
      REAL
     +   YNLOG,YXLOG
      INTEGER
     +   IYN,IYNLOG,IYX,IYXLOG,J,K
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10,MIN,MOD,NINT,REAL
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELY
C     INTEGER ILOGY, ISTEP, IYN, IYNLOG, IYX, IYXLOG, J, K
C     INTEGER NLABLY, NUMROW
C     REAL YLABEL(20)
C        THE Y-AXIS LABLES.
C     REAL YDMN, YDMX
C        THE Y-AXIS DATA LIMITS ACTUALLY USED.
C     REAL YMN, YMX
C        THE Y-AXIS PLOT LIMITS ACTUALLY USED.
C     REAL YNLOG, YWIDTH, YXLOG
C
      IF (ILOGY.EQ.0) THEN
C
        YDMN = YMN
        YDMX = YMX
C
C       DETERMINE THE VALUE OF A DIVISION
C
        DELY=YMX-YMN
        YWIDTH=DELY/(NUMROW-1)
C
C       COMPUTE EVENLY SPACED LABELS FOR NON-LOG AXIS
C
        NLABLY = 0
        DO 10 J = 1, NUMROW, ISTEP
          NLABLY = NLABLY + 1
          YLABEL(NLABLY) = YMX+(1-J)*YWIDTH
   10   CONTINUE
          IF (MOD(NUMROW,ISTEP).EQ.1) YLABEL(NLABLY) = YMN
          IF (YMX.EQ.(-YMN) .AND. MOD(NLABLY,2).EQ.1) THEN
             YLABEL(NLABLY/2+1) = 0.0
          END IF
      ELSE
C
        YDMN = LOG10(YMN)
        YDMX = LOG10(YMX)
C
C       ADJUST AXIS LIMITS FOR LOG AXIS IF NECESSARY
C
        YXLOG=LOG10(YMX)
        IYXLOG=YXLOG
        IF (YMX.LT.1.0E0) IYXLOG=IYXLOG-1
        YNLOG=LOG10(YMN)
        IF ((YXLOG-YNLOG).LE.0.92082E0) THEN
C
C         RANGE IS LESS THAN .9 DECADES
C
          IYNLOG=YNLOG
          IF (YMN.LT.1.0E0) IYNLOG=IYNLOG-1
          IF (IYXLOG.LE.IYNLOG) THEN
C
C           VALUES FALL IN THE SAME DECADE
C
            YNLOG=IYNLOG
            YXLOG=YNLOG+1.0E0
            IYXLOG=YXLOG
          ELSE
C
C           VALUES FALL INTO TWO DECADES
C
            IYN=NINT(YMN/(10.0E0**IYNLOG))
            YNLOG=MIN(LOG10(IYN*(10.0E0**IYNLOG)),YNLOG)
            YXLOG=YNLOG+1.0E0
            IYXLOG=YXLOG
          END IF
        END IF
        YMX=YXLOG
        YMN=YNLOG
C
C       DETERMINE THE VALUE OF A DIVISION
C
        DELY=YMX-YMN
        YWIDTH=DELY/(NUMROW-1)
C
C       COMPUTE AXIS LABELS
C
        YLABEL(1)=10.0E0**YXLOG
        IYX=YLABEL(1)/(10.0E0**IYXLOG)
        K=2
        IF (YXLOG-YNLOG.GT.3.0E0) K=5
        IF (YXLOG-YNLOG.GT.6.0E0) K=10
C
        NLABLY = 1
C
        IF (YXLOG-YNLOG.LE.12.0E0) THEN
C
C       SET NICE LABELS
C
          IF (K.EQ.10) IYX=1
          IF (IYX.NE.1.AND.(IYX-((IYX/K)*K)).NE.0) IYX=((IYX/K)*K)
          IF (IYX.LE.1) THEN
            IYX=10
            IYXLOG=IYXLOG-1
          END IF
          IF (YLABEL(1)-IYX*(10.0E0**IYXLOG).GT.0.0E0 .AND.
     +     YXLOG-(YXLOG-YNLOG)/(2.0E0*(NUMROW-1)) .GT.
     +     LOG10(REAL(IYX))+IYXLOG) IYX=IYX+K
          IYX=IYX-K
          IF (IYX.LE.0) THEN
            IYX=10
            IYXLOG=IYXLOG-1
          END IF
          DO 155 J=2,20
             NLABLY=NLABLY+1
             YLABEL(NLABLY)=IYX*(10.0E0**IYXLOG)
             IF (YLABEL(NLABLY).LE.10.0E0**YNLOG) GO TO 156
             IYX=IYX-K
             IF (IYX.GT.0) GO TO 155
             IYX=10
             IYXLOG=IYXLOG-1
  155     CONTINUE
  156     YLABEL(NLABLY)=10.0E0**YNLOG
        ELSE
C
C         COMPUTE EVENLY SPACED LABELS
C
          DO 160 J = ISTEP, NUMROW, ISTEP
            NLABLY = NLABLY + 1
            YLABEL(NLABLY) = 10.0E0**(YMX+(1.0E0-J)*YWIDTH)
  160     CONTINUE
        END IF
      END IF
C
      RETURN
      END
*LOPASS
      SUBROUTINE LOPASS (Y, N, FC, K, HLP, YF, NYF)
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
      REAL
     +   FC
      INTEGER
     +   K,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   HLP(*),Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      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,IPRINT,LPFLT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
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     REAL 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     REAL 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     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
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.0E0, 0.5E0, 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
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
      CALL LPFLT (FC, K, HLP)
C
      CALL FLTSL (Y, N, K, HLP, YF, NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   46H       CALL LOPASS (Y, N, FC, K, HLP, YF, NYF))
      END
*LPCOEF
      SUBROUTINE LPCOEF (FC, K, HLP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES THE K-TERM LEAST SQUARES
C     APPROXIMATION TO AN -IDEAL- LOW PASS 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
      REAL
     +   FC
      INTEGER
     +   K
C
C  ARRAY ARGUMENTS
      REAL
     +   HLP(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LFC(8)*1,LK(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISII,ERIODD,ERSII,ERSLFS,IPRINT,LPFLT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03, ERR04
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL 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     REAL HLP(K)
C        THE ARRAY IN WHICH THE -IDEAL- LOW 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)
C        THE ARRAY CONTAINING THE NAMES OF THE VARIABLES FC AND K.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'L',       'P',       'C',       'O',       'E',       'F'/
      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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL ERSII(NMSUB, LFC, FC, 0.0E0, 0.5E0, 2, HEAD, ERR01, LFC, LFC)
C
      CALL EISII(NMSUB, LK, K, 1, K, 2, HEAD, ERR02, LK, LK)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR03)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10
C
      CALL ERSLFS(NMSUB, FC, K, HEAD, ERR04)
C
      IF (.NOT. ERR04) GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
      CALL LPFLT (FC, K, HLP)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   31H       CALL LPCOEF (FC, K, HLP))
      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
      REAL
     +   FC
      INTEGER
     +   K
C
C  ARRAY ARGUMENTS
      REAL
     +   HLP(K)
C
C  LOCAL SCALARS
      REAL
     +   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     REAL ARG, CON
C        VARIABLES USED IN THE COMPUTATION OF THE LOW PASS FILTER
C        COEFFICIENTS.
C     REAL FC
C        THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER.
C     REAL 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     REAL PI
C        THE VALUE OF PI.
C     REAL SUM
C        A VALUE USED FOR SUMMING.
C
      CALL GETPI(PI)
C
      KMID = (K + 1) / 2
C
      HLP(KMID) = 1.0E0
C
      IF (K .EQ. 1) RETURN
C
      HLP(KMID) = 2.0E0 * FC
      CON = 2.0E0 * 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.0E0 * 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
*LSQRT
      SUBROUTINE LSQRT(N1, N, L, A, IRC)
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
      REAL
     +   A(1),L(1)
C
C  LOCAL SCALARS
      REAL
     +   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     REAL 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     REAL T, TD, ZERO
C
C/
      DATA ZERO/0.0E0/
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 LSQRT  ***
      END
*LSTLAG
      INTEGER FUNCTION LSTLAG (NLPPA, LAGMAX, LACOV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE FINDS THE LAG VALUE OF THE LAST AUTOCOVARIANCE
C     COMPUTED BEFORE ONE COULD NOT BE COMPUTED DUE TO MISSING DATA.
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   LACOV,LAGMAX
C
C  ARRAY ARGUMENTS
      INTEGER
     +   NLPPA(LACOV)
C
C  LOCAL SCALARS
      INTEGER
     +   LAG
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAG
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        AUTOCORRELATION.
C     INTEGER NLPPA(LACOV)
C        THE ARRAY CONTAINING THE NUMBERS OF LAGGED PRODUCT PAIRS
C        USED TO COMPUTE THE ACVF AT EACH LAG.
C
C     FIND THE LAST AUTOCORRELATION TO BE COMPUTED BEFORE
C     ONE COULD NOT BE COMPUTED DUE TO MISSING DATA
C
      LSTLAG = -1
      IF (NLPPA(1) .LE. 0) RETURN
      DO 20 LAG = 1, LAGMAX
         IF (NLPPA(LAG + 1) .GE. 1) GO TO 20
         LSTLAG = LAG - 1
         RETURN
   20 CONTINUE
      LSTLAG = LAGMAX
      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
      REAL
     +   VEC(N)
      INTEGER
     +   MASK(LMASK)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IMASK,IMAX,IMIN,INDEX,IPRT,J,JMAX,NPERL
C
C  LOCAL ARRAYS
      INTEGER
     +   INDW(10)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   INPERL
      EXTERNAL INPERL
C
C  EXTERNAL SUBROUTINES
      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     REAL VEC(N)
C        THE VECTOR OF VALUES TO BE PRINTED.
C
      CALL IPRINT(IPRT)
C
      NPERL = INPERL(0)
C        NOTE - INPERL(0) IS ASSUMED TO BE AT MOST 10.0E0  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(IPRT, 1010) (INDW(INDEX), INDEX = 1, JMAX)
         WRITE(IPRT, 1020) (VEC(INDEX), INDEX = IMIN, IMAX)
   30 CONTINUE
C
      RETURN
C
   40 WRITE (IPRT, 1030)
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(10X, 5HINDEX, I5, 6I15)
 1020 FORMAT(10X, 5HVALUE, 7(1X, G14.7)/)
 1030 FORMAT (/47H ERROR IN STARPAC.  LSTVEC TRIED TO ACCESS MORE,
     +   29H ELEMENTS THAN EXIST IN MASK.)
C
      END
*LSTVEC
      SUBROUTINE LSTVEC(N, VEC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE INDICES AND ELEMENT VALUES
C     OF THE VECTOR VEC.
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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   VEC(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IMAX,IMIN,INDEX,IPRT,NPERL
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   INPERL
      EXTERNAL INPERL
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER IMAX, IMIN
C        THE LARGEST AND SMALLEST INDEX VALUE TO BE PRINTED ON EACH
C        LINE.
C     INTEGER INDEX
C        THE INDEX VALUE TO BE PRINTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
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     REAL VEC(N)
C        THE VECTOR OF VALUES TO BE PRINTED.
C
      CALL IPRINT(IPRT)
C
      NPERL = INPERL(0)
C
      DO 10 I = 1, N, NPERL
         IMIN = I
         IMAX = MIN(I+NPERL-1, N)
         WRITE(IPRT, 1010) (INDEX, INDEX = IMIN, IMAX)
         WRITE(IPRT, 1020) (VEC(INDEX), INDEX = IMIN, IMAX)
   10 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT(10X, 5HINDEX, I5, 6I15)
 1020 FORMAT(10X, 5HVALUE, 7(1X, G14.7)/)
C
      END
*LSVMIN
      REAL 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
      REAL
     +   L(1),X(P),Y(P)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   V2NORM
      EXTERNAL V2NORM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MOD
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER P
C     REAL 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     REAL B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS
C
C  ***  CONSTANTS  ***
C
C     REAL HALF, ONE, R9973, ZERO
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL V2NORM
C     REAL V2NORM
C
      DATA IX/2/
      DATA HALF/0.5E0/, ONE/1.0E0/, R9973/9973.0E0/, ZERO/0.0E0/
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
*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
      REAL
     +   A(*),L(*)
C
C  LOCAL SCALARS
      REAL
     +   LII,LJ
      INTEGER
     +   I,I1,II,IIM1,J,K,M
C
C     INTEGER N
C     REAL 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     REAL LII, LJ
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
*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
      REAL
     +   J(N,P),URPARM(*),X(P)
      INTEGER
     +   UIPARM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL UFPARM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS,SIN
C
      J(1,1) = 2.0E0*X(1) + X(2)
      J(1,2) = 2.0E0*X(2) + X(1)
      J(2,1) = COS(X(1))
      J(2,2) = 0.0E0
      J(3,1) = 0.0E0
      J(3,2) = -SIN(X(2))
      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
      REAL
     +   R(N),URPARM(*),X(P)
      INTEGER
     +   UIPARM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL UFPARM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS,SIN
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
*MAFLT
      SUBROUTINE MAFLT (Y, N, K, YF, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PERFORMS A SIMPLE MOVING AVERAGE FILTERING
C     OPERATION ON AN INPUT SERIES Y, RETURNING THE FILTERED SERIES
C     IN YF.
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,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   HMA
      INTEGER
     +   IPRT
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LK(8)*1,LN(8)*1,LONE(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,ERIODD,FLTMA,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03
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     REAL HMA
C        THE VALUE OF EACH OF THE SIMPLE MOVING AVERAGE LINEAR FILTER
C        COEFFICIENTS.
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.
C     CHARACTER*1 LK(8), LN(8), LONE(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'M',       'A',       'F',       'L',       'T',       ' '/
      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', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA
     +  LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7),
     +  LONE(8)  /  ' ', ' ', 'O', 'N', 'E', ' ', ' ', ' '/
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 EISII(NMSUB, LK, K, 1, N, 1, HEAD, ERR02, LONE, LN)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR03)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
C     COMPUTE THE SIMPLE MOVING AVERAGE COEFFICIENTS
C
      HMA = K
      HMA = 1.0E0/HMA
C
      CALL FLTMA (Y, N, K, HMA, YF, NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MAFLT (Y, N, K, YF, NYF)')
      END
*MATPRF
      SUBROUTINE MATPRF(X, Y, NC, MODE, CODE, LENGTH, MASK, LMASK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THISROUTINE 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
      REAL
     +   X(LENGTH),Y(LENGTH)
      INTEGER
     +   MASK(LMASK)
C
C  LOCAL SCALARS
      REAL
     +   SQXII,SQYII
      INTEGER
     +   I,I0,II,IK,IMASK,IPRT,J,JMASK,K,KI,KK,KM,KMAX,KN,L,NF,
     +   NLINE
C
C  LOCAL ARRAYS
      REAL
     +   XLINE(10),YLINE(10)
      INTEGER
     +   INDW(10)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   INPERL
      EXTERNAL INPERL
C
C  EXTERNAL SUBROUTINES
      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     REAL SQXII, SQYII
C        THE SQUARE ROOT OF THE (I,I)TH ELEMENT OF X AND Y.
C     REAL X(LENGTH)
C        INPUT SYMMETRIC ARRAY STORED ROW WISE
C     REAL XLINE(10)
C        THE CURRENT VALUES BEING PRINTED FROM ARRAY X.
C     REAL Y(LENGTH)
C        ARRAY TO BE PRINTED ON THE SECOND LEVEL IF CODE=2
C     REAL YLINE(10)
C        THE CURRENT VALUES BEING PRINTED FROM ARRAY Y.
C
C     BODY OF ROUTINE
C
      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 (IPRT,1000) (INDW(K),K=1,KMAX)
         WRITE (IPRT,1030)
         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.0E0
            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 (IPRT,1010) IMASK, (XLINE(K),K=1,NLINE)
            IF (CODE.EQ.2) WRITE (IPRT,1020) (YLINE(K),K=1,NLINE)
            IF (CODE.EQ.2) WRITE (IPRT,1030)
   80    CONTINUE
   90 CONTINUE
      RETURN
C
  100 WRITE (IPRT,1040)
      RETURN
C
C     FORMAT STATEMENTS
C
C
 1000 FORMAT (/' ', 7HCOLUMN , 7(I9, 8X))
 1010 FORMAT (' ', I6, 1X, 7(3X, G14.7))
 1020 FORMAT (' ', 5X, 7(3X, G14.7))
 1030 FORMAT (' ')
 1040 FORMAT (/47H ERROR IN STARPAC.  MATPRF TRIES TO ACCESS MORE,
     +   29H ELEMENTS THAN EXIST IN MASK.)
      END
*MATPRT
      SUBROUTINE MATPRT (X, Y, NC, IPRT, MODE, CODE, IRDIM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE TAKES A SQUARE MATRIX AND PRINTS EITHER ITS
C     LOWER TRIANGULAR PART OR THE FULL MATRIX WITH OR WITHOUT DOUBLE
C     PRINTING.
C
C     WRITTEN BY - LINDA L. MITCHELL
C                  STATISTICAL ENGINEERING LAB/BOULDER
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   CODE,IPRT,IRDIM,MODE,NC
C
C  ARRAY ARGUMENTS
      REAL
     +   X(IRDIM,NC),Y(IRDIM,NC)
C
C  LOCAL SCALARS
      REAL
     +   TEMP
      INTEGER
     +   I,IWIDTH,J,K,KM,KN,L,NF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CODE
C                  IF 1 -SINGLE PRINTED LINE, X ONLY (Y IS DUMMY ARG)
C                     2 -DOUBLE PRINTED LINE, BOTH X AND Y
C     INTEGER I
C                  ROW NUMBER
C     INTEGER IPRT
C                  THE OUTPUT UNIT NUMBER
C     INTEGER IRDIM
C                  ROW INDEX OF X
C     INTEGER IWIDTH
C                  THE WIDTH OF THE OUTPUT DEVICE.
C     INTEGER J
C                  FIRST COLUMN IN THE SET TO BE PRINTED
C     INTEGER K
C                  COLUMN NUMBER IN THE POSSIBLE SET OF NF
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 KN
C                  LAST COLUMN TO PRINT WHEN PRINTING LOWER TRIANGLE
C     INTEGER L
C                  FIRST ROW TO PRINT FOR THIS SET
C     INTEGER MODE
C                  IF 0, LOWER TRIANGULAR PART PRINTED
C                     1, FULL MATRIX PRINTED
C                     2, LOWER TRIANGULAR PART IS PRINTED WITH
C                        SQUARE ROOTS OF 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     REAL TEMP
C                  A TEMPORARY LOCATION
C     REAL X(IRDIM,NC)
C                  NC BY NC INPUT MATRIX
C     REAL Y(IRDIM,NC)
C                  MATRIX TO BE PRINTED ON THE SECOND LEVEL IF CODE=2
C
      IWIDTH = 132
      NF = MIN(7, (IWIDTH - 7)/17)
      L = 1
      DO 20 J=1,NC, NF
         KN = MIN(NC, J+NF-1)
         WRITE(IPRT,1000) (K,K=J,KN)
         WRITE(IPRT,1030)
         IF ((MODE.EQ.00) .OR. (MODE.EQ.2)) L = J
         DO 10 I=L,NC
            TEMP = X(I,I)
            KM = KN
            IF ((MODE.EQ.0) .OR. (MODE.EQ.2))
     +         KM = J + MIN(I-L, NF-1)
            IF ((MODE.EQ.2) .AND. ((I.GE.J) .AND. (I.LE.KM)))
     +         X(I,I) = SQRT(X(I,I))
            WRITE(IPRT,1010) I, (X(I,K),K=J,KM)
            IF (CODE.EQ.2) WRITE(IPRT,1020) (Y(I,K),K=J,KM)
            IF (CODE.EQ.2) WRITE(IPRT,1030)
            X(I,I) = TEMP
   10    CONTINUE
   20 CONTINUE
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/4X, 7HCOLUMN , 7(I9, 8X))
 1010 FORMAT (4X, I6, 1X, 7(3X, G14.8))
 1020 FORMAT (9X, 7(3X, G14.8))
 1030 FORMAT (4X)
      END
*MDFLT
      SUBROUTINE MDFLT (PER, NF, NK, KMD, PERF, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR APPLYING MODIFIED
C     DANIEL FILTERS TO A SYMMETRIC SERIES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LDSTAK,NF,NK
C
C  ARRAY ARGUMENTS
      REAL
     +   PER(*),PERF(*)
      INTEGER
     +   KMD(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   SYM
      INTEGER
     +   I,IPRT,L,LDSMIN,NALL0,WORK
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      CHARACTER
     +   LKMD(8)*1,LLDS(8)*1,LNF(8)*1,LNK(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EIVEO,FLTMD,IPRINT,LDSCMP,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      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     LOGICAL ERR01, ERR02, ERR03
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT NUMBER USED FOR OUTPUT.
C     INTEGER KMD(NK)
C        THE ARRAY OF FILTER LENGTHS.
C     CHARACTER*1 LKMD(8), LLDS(8), LNK(8), LNF(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING STACK ALLOCATIONS
C     INTEGER NF
C        THE NUMBER OF POINTS IN THE SERIES TO BE FILTERED.
C     INTEGER NK
C        THE NUMBER OF FILTERS TO BE APPLIED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     REAL PER(NF)
C        THE INPUT SERIES TO BE FILTERED.
C     REAL PERF(NF)
C        THE FILTERED SERIES.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SYM
C        AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SERIES
C        IS SYMMETRIC (SYM = 1.0E0) OR NOT (SYM = -1.0E0).
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR THE WORK VECTOR.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'M',       'D',       'F',       'L',       'T',       ' '/
      DATA
     + LKMD(1), LKMD(2), LKMD(3), LKMD(4), LKMD(5),
     +  LKMD(6), LKMD(7), LKMD(8) /'K','M','D',' ',' ',' ',' ',' '/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     +  LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5),
     +  LNF(6), LNF(7), LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/
      DATA
     + LNK(1), LNK(2), LNK(3), LNK(4), LNK(5),
     +  LNK(6), LNK(7), LNK(8) /'N','K',' ',' ',' ',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LNF, NF, 17, 1, HEAD, ERR01, LNF)
C
      CALL EISGE(NMSUB, LNK, NK, 1, 1, HEAD, ERR02, LNK)
C
      IF (.NOT.ERR02) CALL EIVEO(NMSUB, LKMD, KMD, NK, .TRUE., HEAD)
C
      IF (ERR01) GO TO 10
C
      CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NF, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS)
C
      IF ((.NOT.ERR02) .AND. (.NOT.ERR03)) GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
C     SET THE SIZE OF THE WORK AREA
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
C     SUBDIVIDE THE WORK AREA
C
      WORK = STKGET(NF, 3)
C
C     DESIGNATE THE SERIES IS SYMMETRIC
C
      SYM = 1.0E0
C
      DO 30 I = 1, NF
         PERF(I) = PER(I)
   30 CONTINUE
C
      DO 40 L = 1, NK
         CALL FLTMD(PERF, RSTAK(WORK), NF, KMD(L), SYM)
   40 CONTINUE
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL MDFLT (PER, NF, NK, KMD, PERF, LDSTAK)')
      END
*MDL1
      SUBROUTINE MDL1(PAR, NPAR, XM, N, M, IXM, PV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     MODEL FUNCTION FOR NLS EXERCISER
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
      REAL
     +   PAR(NPAR),PV(N),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL PAR(NPAR)
C        MODEL PARAMETERS
C     INTEGER I
C        ROW INDEX
C     INTEGER IXM
C        ACTUAL FIRST DIMENSION OF XM
C     INTEGER M
C        NUMBER OF VARIABLES
C     INTEGER N
C        NUMBER OF OBSERVATIONS
C     INTEGER NPAR
C        NUMBER OF PARAMETERS
C     REAL PV(N)
C        PREDICTED VALUES
C     REAL XM(IXM,M)
C        INDEPENDENT VARIABLES
C
      DO 10 I=1,N
         PV(I) = PAR(1)*XM(I,1)**PAR(2)
   10 CONTINUE
      RETURN
      END
*MDL2
      SUBROUTINE MDL2(PAR, NPAR, XM, N, M, IXM, PV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     MODEL FUNCTION FOR NLS EXERCISER
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
      REAL
     +   PAR(NPAR),PV(N),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        ROW INDEX
C     INTEGER IXM
C        ACTUAL FIRST DIMENSION OF XM
C     INTEGER M
C        NUMBER OF VARIABLES
C     INTEGER N
C        NUMBER OF OBSERVATIONS
C     INTEGER NPAR
C        NUMBER OF PARAMETERS
C     REAL PAR(NPAR)
C        MODEL PARAMETERS
C     REAL PV(N)
C        PREDICTED VALUES
C     REAL XM(IXM,M)
C        INDEPENDENT VARIABLES
C
      DO 10 I=1,N
         PV(I) = PAR(1)*XM(I,1) + PAR(2)*XM(I,2) + PAR(3)*XM(I,3)**3
   10 CONTINUE
      RETURN
      END
*MDL3
      SUBROUTINE MDL3(PAR, NPAR, XM, N, M, IXM, PV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     MODEL FUNCTION FOR NLS EXERCISER
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
      REAL
     +   PAR(NPAR),PV(N),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        ROW INDEX
C     INTEGER IXM
C        ACTUAL FIRST DIMENSION OF XM
C     INTEGER M
C        NUMBER OF VARIABLES
C     INTEGER N
C        NUMBER OF OBSERVATIONS
C     INTEGER NPAR
C        NUMBER OF PARAMETERS
C     REAL PAR(NPAR)
C        MODEL PARAMETERS
C     REAL PV(N)
C        PREDICTED VALUES
C     REAL XM(IXM,M)
C        INDEPENDENT VARIABLES
C
      DO 10 I=1,N
         PV(I) = PAR(1)*XM(I,1) + PAR(2)*XM(I,2) + PAR(3)*XM(I,3) +
     +      PAR(4)*XM(I,4) + PAR(5)*XM(I,5)
   10 CONTINUE
      RETURN
      END
*MDL4
      SUBROUTINE MDL4 (PAR, NPAR, XM, N, M, IXM, PV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     MODEL ROUTINE FOR STEP SIZE AND DERIVATIVE CHECKING 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
     +   IXM,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PV(N),XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP
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 M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN COEFFICIENTS IN THE MODEL.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        COEFFICIENTS ARE STORED.
C     REAL PV(N)
C        THE PREDICTED VALUES FROM THE FIT.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
      DO 10 I = 1, N
         PV(I) = PAR(1) + PAR(3)*EXP(-((XM(I,1)-PAR(2))**2)/PAR(4))
   10 CONTINUE
C
      RETURN
C
      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
      REAL
     +   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
      REAL
     +   PMU
      INTEGER
     +   I,I1
C
C  LOCAL ARRAYS
      REAL
     +   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     REAL 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     REAL PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     REAL RESTS(NRESTS)
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     REAL RSTAK(12)
C        THE REAL 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     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
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
*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
      REAL
     +   PMU
      INTEGER
     +   IFLAG,MBO,N,N1,N2,NFAC,NPAR,NPARDF
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PARAR(*),PARDF(*),PARMA(*),RESTS(N1:N2),T(*),
     +   TEMP(*),Y(N)
      INTEGER
     +   MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      REAL
     +   FPLPM,RESMAX,WTEST
      INTEGER
     +   I,IMOD,IMOD1,IPAR,IPQ,ISTART,J,K,L,MAXORD,MBO1,NP,NPARAR,
     +   NPARMA
      LOGICAL
     +   PARLE1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG,MOD,SIGN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PARAR(MBO)
C        THE AUTOREGRESSIVE PARAMETERS
C     REAL 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     REAL PARMA(MBO)
C        THE MOVING AVERAGE PARAMETERS
C     REAL PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     REAL RESMAX
C        THE LARGEST POSSIBLE RESIDUAL WHICH WILL STILL AVOID OVERFLOW.
C     REAL RESTS(N1:N2)
C        THE PREDICTED VALUE OF THE FIT.
C     REAL T(2*MBO)
C        A TEMPORARY WORK VECTOR.
C     REAL TEMP(MBO)
C        A TEMPORARY WORK VECTOR
C     REAL WTEST
C        THE TEST VALUE USED TO DETERMINE IF THE DIFFERENCED SERIES
C        BACK FORECAST IS EFFECTIVELY ZERO OR NOT.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
      FPLPM = R1MACH(2)
C
C     ZERO THE PARAMETER ARRAYS PARAR AND PARMA
C
      DO 10 I=1,MBO
         T(I) = 0.0E0
         TEMP(I) = 0.0E0
   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.0E0
               TEMP(K) = 0.0E0
  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.0E0) 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.0E0
         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.0E0 .AND. T(IMOD1).NE.0.0E0) THEN
                     IF (LOG(ABS(PARMA(J)))+LOG(ABS(T(IMOD1))).LT.
     +                         LOG(FPLPM)
     +                     .AND.
     +                     (SIGN(1.0E0,T(IMOD)).NE.
     +                         SIGN(1.0E0,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.0E0
  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
*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
      REAL
     +   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
      REAL
     +   PMU
C
C  LOCAL ARRAYS
      REAL
     +   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     REAL 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     REAL PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     REAL RESTS(NRESTS)
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     REAL RSTAK(12)
C        THE REAL 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     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
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
      RETURN
      END
*MGS
      SUBROUTINE MGS(A, B, N, NP, X, C, D, R, IR, IA, IER)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE SOLUTION  X  TO THE LINEAR SYSTEM OF
C     EQUATIONS  AX=B, USING THE METHOD OF MODIFIED GRAM-SCHMIDT.
C     THE MATRIX A IS DECOMPOSED INTO THREE MATRICES
C        Q  AN ORTHOGONAL MATRIX
C        D  A DIAGONAL MATRIX AND
C        R  AN UPPER TRIANGULAR MATRIX
C     THE SOLUTION VECTOR X IS THE VECTOR WHICH SOLVES THE SYSTEM
C     OF EQUATIONS  RX = C
C     X, A, AND B ARE NOT PRESERVED ON OUTPUT
C
C     ADAPTED FROM OMNITAB II BY -
C                  JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IA,IER,IR,N,NP
C
C  ARRAY ARGUMENTS
      REAL
     +   A(IA,NP),B(N),C(NP),D(NP),R(IR,NP),X(NP)
C
C  LOCAL SCALARS
      REAL
     +   SM1,SM2
      INTEGER
     +   I,J,JJ,K,NPJJMJ
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL A(IA,NP)
C           THE COEFFICIENTS MATRIX (NOT PRESERVED ON OUTPUT)
C     REAL B(N)
C           THE CONSTANT COLUMN MATRIX OF THE SYSTEM (NOT PRESERVED
C           ON OUTPUT)
C     REAL C(NP)
C           THE MATRIX C DESCRIBED ABOVE
C     REAL D(NP)
C           THE DIAGONAL ELEMENTS OF THE MATRIX D DESCRIBED ABOVE
C     INTEGER I
C           *
C     INTEGER IA
C           THE ROW DIMENSION OF A.
C     INTEGER IER
C           *
C     INTEGER IR
C           THE ROW DIMENSION OF R.
C     INTEGER J
C           *
C     INTEGER JJ
C           *
C     INTEGER K
C           *
C     INTEGER N
C           THE NUMBER OF OBSERVATIONS
C     INTEGER NP
C           THE NUMBER OF PARAMETERS
C     INTEGER NPJJMJ
C           *
C     REAL R(IR,NP)
C           THE UPPER ELEMENTS OF THE MATRIX R DESCRIBED ABOVE
C     REAL SM1
C           *
C     REAL SM2
C           *
C     REAL X(NP)
C           THE SOLUTION MATRIX
C
C
      IER = 0
C
      SM1 = 0.0E0
      SM2 = 0.0E0
      DO 10 I=1,N
         SM1 = A(I,1)*A(I,1) + SM1
         SM2 = A(I,1)*B(I) + SM2
   10 CONTINUE
      IF (SM1.EQ.0.0E0) GO TO 100
      D(1) = SM1
      C(1) = SM2/SM1
      IF (NP.EQ.1) GO TO 70
      DO 60 K=2,NP
         DO 40 J=K,NP
            SM1 = 0.0E0
            DO 20 I=1,N
               SM1 = A(I,K-1)*A(I,J) + SM1
   20       CONTINUE
            R(K-1,J) = SM1/D(K-1)
            DO 30 I=1,N
               A(I,J) = A(I,J) - A(I,K-1)*R(K-1,J)
   30       CONTINUE
   40    CONTINUE
         SM1 = 0.0E0
         SM2 = 0.0E0
         DO 50 I=1,N
            B(I) = B(I) - A(I,K-1)*C(K-1)
            SM1 = A(I,K)*A(I,K) + SM1
            SM2 = A(I,K)*B(I) + SM2
   50    CONTINUE
         IF (SM1.EQ.0.0E0) GO TO 100
         D(K) = SM1
         C(K) = SM2/SM1
   60 CONTINUE
C
C     COMPLETE BACKSOLVE
C
   70 X(NP) = C(NP)
      IF (NP.EQ.1) RETURN
      DO 90 I=2,NP
         K = NP + 1 - I
         JJ = K + 1
         SM1 = 0.0E0
         DO 80 J=JJ,NP
            NPJJMJ = NP + JJ - J
            SM1 = R(K,NPJJMJ)*X(NPJJMJ) + SM1
   80    CONTINUE
         X(K) = C(K) - SM1
   90 CONTINUE
      RETURN
  100 IER = 1
      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
      INTEGER
     +   I,IPRT,J
C
C  EXTERNAL SUBROUTINES
      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
C
      CALL IPRINT(IPRT)
C
C     PRINT MODEL SPECIFICATION
C
      WRITE(IPRT, 1002) (I, (MSPECT(I,J),J=1,4), I=1,NFAC)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1002 FORMAT(//
     +   '    MODEL SPECIFICATION'//
     +   '       FACTOR          (P     D     Q)    S'//
     +   (7X, I6, 6X, 4I6))
      END
*MPPC
      SUBROUTINE MPPC(YM, X, N, M, IYM, ILOG, ISIZE, NOUT, YLB, YUB,
     +  XLB, XUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH MULTIPLE Y-AXIS VALUES (LONG CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,IYM,M,N,NOUT
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XMISS
      INTEGER
     +   IPRT,ISCHCK,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'P',       'P',       'C',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      XMISS = 1.0E0
      MULTI = .TRUE.
      ISCHCK = 2
      MISS = .FALSE.
      LISYM = 1
C
      CALL PPCNT (YM, YM, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL MPPC (YM, X, N, M, IYM, ILOG,'/
     +  '      +           ISIZE, NOUT, YLB, YUB, XLB, XUB)')
      END
*MPP
      SUBROUTINE MPP(YM, X, N, M, IYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH MULTIPLE Y-AXIS VALUES (SHORT CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IYM,M,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,IPRT,ISCHCK,ISIZE,LISYM,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'P',       'P',       ' ',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      XMISS = 1.0E0
      MULTI = .TRUE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 2
      ISIZE = -1
      NOUT = 0
      MISS = .FALSE.
      LISYM = 1
C
      CALL PPCNT (YM, YM, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MPP (YM, X, N, M, IYM)')
      END
*MPPL
      SUBROUTINE MPPL(YM, X, N, M, IYM, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH MULTIPLE Y-AXIS VALUES (LOG OPTION).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,IYM,M,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   IPRT,ISCHCK,ISIZE,LISYM,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'P',       'P',       'L',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      XMISS = 1.0E0
      MULTI = .TRUE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 2
      ISIZE = -1
      NOUT = 0
      MISS = .FALSE.
      LISYM = 1
C
      CALL PPCNT (YM, YM, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MPPL (YM, X, N, M, IYM, ILOG)')
      END
*MPPMC
      SUBROUTINE MPPMC(YM, YMMISS, X, XMISS, N, M, IYM, ILOG, ISIZE,
     +   NOUT, YLB, YUB, XLB, XUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH MULTIPLE Y-AXIS VALUES AND WITH MISSING
C     OBSERVATIONS (LONG CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,IYM,M,N,NOUT
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISCHCK,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,M)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'P',       'P',       'M',       'C',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      ISCHCK = 2
      MISS = .TRUE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MPPMC (YM, YMMISS, X, XMISS, N, M, IYM, ILOG,'/
     +   '      +            ISIZE, NOUT, YLB, YUB, XLB, XUB)')
      END
*MPPM
      SUBROUTINE MPPM(YM, YMMISS, X, XMISS, N, M, IYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH MULTIPLE Y-AXIS VALUES AND WITH MISSING
C     OBSERVATIONS (SHORT CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XMISS
      INTEGER
     +   IYM,M,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   ILOG,IPRT,ISCHCK,ISIZE,LISYM,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'P',       'P',       'M',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 2
      ISIZE = -1
      NOUT = 0
      MISS = .TRUE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MPPM (YM, YMMISS, X, XMISS, N, M, IYM)')
      END
*MPPML
      SUBROUTINE MPPML(YM, YMMISS, X, XMISS, N, M, IYM, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH MULTIPLE Y-AXIS VALUES AND WITH MISSING
C     OBSERVATIONS (LOG OPTION).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XMISS
      INTEGER
     +   ILOG,IYM,M,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   IPRT,ISCHCK,ISIZE,LISYM,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'P',       'P',       'M',       'L',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 2
      ISIZE = -1
      NOUT = 0
      MISS = .TRUE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MPPML (YM, YMMISS, X, XMISS, N, M, IYM, ILOG)')
      END
*MSGX
      SUBROUTINE MSGX(IER, IPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE RETURNED AND EXPECTED VALUES FOR THE
C     ERROR FLAG IERR
C
C     WRITTEN BY -
C        LINDA MITCHELL
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IER,IPRT
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIBLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IER
C        EXPECTED VALUE OF ERROR FLAG IERR
C     INTEGER IERR
C        RETURNED ERROR FLAG FOUND IN THE COMMON ERRCHK
C     INTEGER IPRT
C        LOGICAL OUTPUT DEVICE
C
C
C     PRINT MESSAGE
      WRITE (IPRT,1000) IER, IERR
C
      IF (IER.NE.IERR) WRITE (IPRT,1010)
C
      RETURN
C
C     FORMAT STATEMENT
C
 1000 FORMAT(/28H EXPECTED VALUE FOR IERR IS , I1/15H RETURNED VALUE,
     +   12H FOR IERR IS, I2)
 1010 FORMAT(48H POSSIBLE ERROR, UNEXPECTED VALUE FOR ERROR FLAG)
      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
      REAL
     +   C(MBO),T(2*MBO),TEMP(MBO)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J,JI,K
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL T(2*MBO)
C        A TEMPORARY WORK VECTOR.
C     REAL TEMP(MBO)
C        A TEMPORARY WORK VECTOR
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.0E0
   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
*MVCHK
      LOGICAL FUNCTION MVCHK (X, XMISS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER X = XMISS (MVCHK = TRUE) OR NOT
C     (MVCHK = FALSE) IN A MANNER WHICH WILL PREVENT VERY LARGE OR
C     VERY SMALL MISSING VALUE CODES FROM CAUSING AN OVERFLOW.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   X,XMISS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL X
C        THE VALUE TO BE CHECKED.
C     REAL XMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IS MISSING.  IF X = XMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C
      IF ((X .GT. 0.0E0 .AND. XMISS .LT. 0.0E0) .OR.
     +    (X .LT. 0.0E0 .AND. XMISS .GT. 0.0E0)) GO TO 10
C
      IF (ABS(X) .EQ. ABS(XMISS)) GO TO 20
C
   10 MVCHK = .FALSE.
      RETURN
C
   20 MVCHK = .TRUE.
      RETURN
C
      END
*MVPC
      SUBROUTINE MVPC(YM, N, M, IYM, NS, ILOG, ISIZE,
     +   YLB, YUB, XLB, XINC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MULTIPLE Y-AXIS VALUES (LONG CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,IYM,M,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'V',       'P',       'C',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      IRLIN = -1
      IBAR = -1
      ISCHCK = 2
      MISS = .FALSE.
      LISYM = 1
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL MVPC (YM, N, M, IYM, NS, ILOG,'/
     + '      +           ISIZE, YLB, YUB, XLB, XINC)')
      END
*MVP
      SUBROUTINE MVP(YM, N, M, IYM, NS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MULTIPLE Y-AXIS VALUES (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IYM,M,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'V',       'P',       ' ',       ' ',       ' '/
C
C     DEFINE CONSTANTS
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 2
      ISIZE = -1
      MISS = .FALSE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MVP (YM, N, M, IYM, NS)')
      END
*MVPL
      SUBROUTINE MVPL(YM, N, M, IYM, NS, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MULTIPLE Y-AXIS VALUES (LOG PLOT OPTION).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,IYM,M,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,ISIZE,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'V',       'P',       'L',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 2
      ISIZE = -1
      MISS = .FALSE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL MVPL (YM, N, M, IYM, NS, ILOG)')
      END
      SUBROUTINE MVPMC(YM, YMMISS, N, M, IYM, NS, ILOG, ISIZE,
     +   YLB, YUB, XLB, XINC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA AND MULTIPLE Y-AXIS VALUES (LONG CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,IYM,M,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'V',       'P',       'M',       'C',       ' '/
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      IRLIN = -1
      IBAR = -1
      ISCHCK = 2
      MISS = .TRUE.
      LISYM = 1
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL MVPMC (YM, YMMISS, N, M, IYM, NS, ILOG,'/
     +  '      +            ISIZE, YLB, YUB, XLB, XINC)')
      END
      SUBROUTINE MVPM(YM, YMMISS, N, M, IYM, NS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA AND MULTIPLE Y-AXIS VALUES
C     (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IYM,M,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'V',       'P',       'M',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 2
      ISIZE = -1
      MISS = .TRUE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL MVPM (YM, YMMISS, N, M, IYM, NS)')
      END
*MVPML
      SUBROUTINE MVPML(YM, YMMISS, N, M, IYM, NS, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA AND MULTIPLE Y-AXIS VALUES
C     (LOG PLOT OPTION).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,IYM,M,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,ISIZE,LISYM
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'M',       'V',       'P',       'M',       'L',       ' '/
C
C     SET DEFAULT VALUES
C
      MULTI = .TRUE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 2
      ISIZE = -1
      MISS = .TRUE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL MVPML (YM, YMMISS, N, M, IYM, NS, ILOG)')
      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
      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
*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
      REAL
     +   D(P),J(NN,P),R(N),V(*),X(P)
      INTEGER
     +   IV(*)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   DOTPRD,R1MACH,V2NORM
      LOGICAL
     +   STOPX
      EXTERNAL DOTPRD,R1MACH,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     REAL 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     REAL E, RDOF1, STTSST, T, T1
C
C     ***  CONSTANTS  ***
C
C     REAL 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     REAL DOTPRD, R1MACH, 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
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.5E0/, NEGONE/-1.0E0/, ONE/1.0E0/, ZERO/0.0E0/
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(R1MACH(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
*NL2SNO
      SUBROUTINE NL2SNO(N, P, X, CALCR, IV, V, UIPARM, URPARM, UFPARM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  LIKE NL2SOL, BUT WITHOUT CALCJ -- MINIMIZE NONLINEAR SUM OF  ***
C  ***  SQUARES USING FINITE-DIFFERENCE JACOBIAN APPROXIMATIONS      ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,P
C
C  ARRAY ARGUMENTS
      REAL
     +   URPARM(1),V(1),X(P)
      INTEGER
     +   IV(1),UIPARM(1)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL CALCR,UFPARM
C
C  LOCAL SCALARS
      REAL
     +   H,HFAC,HLIM,NEGPT5,ONE,XK,ZERO
      INTEGER
     +   COVPRT,COVREQ,D,D1,DK,DLTFDJ,DTYPE,I,J,J1,J1K,K,NF,NFCALL,
     +   NFGCAL,R,R1,RN,TOOBIG
      LOGICAL
     +   STRTED
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RMDCON
      EXTERNAL RMDCON
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DFAULT,ITSMRY,NL2ITR,VSCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX
C
C     INTEGER N, P, IV(1), UIPARM(1)
C     REAL X(P), V(1), URPARM(1)
C     DIMENSION IV(60+P),  V(93 + N*P + 3*N + P*(3*P+33)/2)
C     EXTERNAL CALCR, UFPARM
C
C-----------------------------  DISCUSSION  ----------------------------
C
C        THE PARAMETERS FOR NL2SNO ARE THE SAME AS THOSE FOR NL2SOL
C     (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED.  INSTEAD OF CALLING
C     CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, NL2SNO COMPUTES
C     AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE
C     V(DLTFDJ) BELOW.  NL2SNO USES FUNCTION VALUES ONLY WHEN COMPUT-
C     THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS
C     THAT NL2SOL MAY USE).  TO DO SO, NL2SNO SETS IV(COVREQ) TO -1 IF
C     IV(COVPRT) = 1 WITH IV(COVREQ) = 0 AND TO MINUS ITS ABSOLUTE
C     VALUE OTHERWISE.  THUS V(DELTA0) IS NEVER REFERENCED AND ONLY
C     V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC).
C        THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO-
C     BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION
C     COUNT IV(NFCALL) AND ARE NOT OTHERWISE REPORTED.
C
C V(DLTFDJ)... V(36) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
C             FINITE-DIFFERENCE JACOBIAN MATRIX.  FOR DIFFERENCES IN-
C             VOLVING X(I), THE STEP SIZE FIRST TRIED IS
C                       V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)),
C             WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).  (IF
C             THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN
C             SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE-
C             LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF.
C             DEFAULT = MACHEP**0.5.
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 TRANS.
C             MATH. SOFTWARE.
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+++++++++++++++++++++++++++  DECLARATIONS  ++++++++++++++++++++++++++++
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL DFAULT, ITSMRY, NL2ITR, RMDCON, VSCOPY
C     REAL RMDCON
C
C DFAULT... SUPPLIES DEFAULT PARAMETER VALUES.
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO-
C             RITHM.
C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C
C     LOGICAL STRTED
C     INTEGER DK, D1, I, J1, J1K, K, NF, RN, R1
C     REAL H, HFAC, HLIM, NEGPT5, ONE, XK, ZERO
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER COVPRT, COVREQ, D, DLTFDJ, DTYPE, J, NFCALL, NFGCAL, R,
C    1        TOOBIG
C
      DATA HFAC/1.0E3/, HLIM/0.0E0/, NEGPT5/-0.5E0/,
     +     ONE/1.0E0/, ZERO/0.0E0/
C
C  ***  IV SUBSCRIPT VALUES  ***
C
      DATA COVPRT/14/, COVREQ/15/, D/27/, DTYPE/16/, J/33/,
     +     NFCALL/6/, NFGCAL/7/, R/50/, TOOBIG/2/
C
C  ***  V SUBSCRIPT VALUES  ***
C
      DATA DLTFDJ/36/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      D1 = 94 + 2*N + P*(3*P + 31)/2
      IV(D) = D1
      R1 = D1 + P
      IV(R) = R1
      J1 = R1 + N
      IV(J) = J1
      RN = J1 - 1
      IF (IV(1) .EQ. 0) CALL DFAULT(IV, V)
      IV(COVREQ) = -ABS(IV(COVREQ))
      IF (IV(COVPRT) .NE. 0 .AND. IV(COVREQ) .EQ. 0) IV(COVREQ) = -1
      STRTED = .TRUE.
      IF (IV(1) .NE. 12) GO TO 80
         STRTED = .FALSE.
         IV(NFCALL) = 1
         IV(NFGCAL) = 1
C        ***  INITIALIZE SCALE VECTOR D TO ONES FOR COMPUTING
C        ***  INITIAL JACOBIAN.
         IF (IV(DTYPE) .GT. 0) CALL VSCOPY(P, V(D1), ONE)
C
 10   NF = IV(NFCALL)
      CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
      IF (STRTED) GO TO 20
         IF (NF .GT. 0) GO TO 30
              IV(1) = 13
              GO TO 90
C
 20   IF (NF .LE. 0) IV(TOOBIG) = 1
      GO TO 80
C
C  ***  COMPUTE FINITE-DIFFERENCE JACOBIAN  ***
C
 30   J1K = J1
      DK = D1
      DO 70 K = 1, P
         XK = X(K)
         H = V(DLTFDJ) * MAX(ABS(XK), ONE/V(DK))
         DK = DK + 1
 40      X(K) = XK + H
         NF = IV(NFGCAL)
         CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM)
         IF (NF .GT. 0) GO TO 50
              IF (HLIM .EQ. ZERO) HLIM = HFAC * RMDCON(3)
C             ***  HLIM = HFAC TIMES THE UNIT ROUNDOFF  ***
              H = NEGPT5 * H
              IF (ABS(H) .GE. HLIM) GO TO 40
                   IV(1) = 15
                   GO TO 90
 50      X(K) = XK
         DO 60 I = R1, RN
              V(J1K) = (V(J1K) - V(I)) / H
              J1K = J1K + 1
 60           CONTINUE
 70      CONTINUE
C
      STRTED = .TRUE.
C
 80   CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X)
      IF (IV(1) - 2) 10, 30, 999
C
 90   CALL ITSMRY(V(D1), IV, P, V, X)
C
 999  RETURN
C  ***  LAST CARD OF NL2SNO FOLLOWS  ***
      END
*NL2SOL
      SUBROUTINE NL2SOL(N, P, X, CALCR, CALCJ, IV, V, UIPARM, URPARM,
     +                  UFPARM)
C
C  ***  MINIMIZE NONLINEAR SUM OF SQUARES USING ANALYTIC JACOBIAN  ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,P
C
C  ARRAY ARGUMENTS
      REAL
     +   URPARM(*),V(*),X(P)
      INTEGER
     +   IV(*),UIPARM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL CALCJ,CALCR,UFPARM
C
C  LOCAL SCALARS
      INTEGER
     +   D,D1,J,J1,NF,NFCALL,NFGCAL,R,R1,TOOBIG
      LOGICAL
     +   STRTED
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ITSMRY,NL2ITR
C
C
C     INTEGER N, P, IV(1), UIPARM(1)
C     REAL X(P), V(1), URPARM(1)
C     DIMENSION IV(60+P),  V(93 + N*P + 3*N + P*(3*P+33)/2)
C     DIMENSION UIPARM(*), URPARM(*)
C     EXTERNAL CALCR, CALCJ, UFPARM
C
C  ***  PURPOSE  ***
C
C        GIVEN A P-VECTOR X OF PARAMETERS, CALCR COMPUTES AN N-VECTOR
C     R = R(X) OF RESIDUALS CORRESPONDING TO X.  (R(X) PROBABLY ARISES
C     FROM A NONLINEAR MODEL INVOLVING P PARAMETERS AND N OBSERVATIONS.)
C     THIS ROUTINE INTERACTS WITH NL2ITR TO SEEK A PARAMETER VECTOR X
C     THAT MINIMIZES THE SUM OF THE SQUARES OF (THE COMPONENTS OF) R(X),
C     I.E., THAT MINIMIZES THE SUM-OF-SQUARES FUNCTION
C     F(X) = (R(X)**T) * R(X) / 2.  R(X) IS ASSUMED TO BE A TWICE CON-
C     TINUOUSLY DIFFERENTIABLE FUNCTION OF X.
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C N........ (INPUT) THE NUMBER OF OBSERVATIONS, I.E., THE NUMBER OF
C                  COMPONENTS IN R(X).  N MUST BE .GE. P.
C P........ (INPUT) THE NUMBER OF PARAMETERS (COMPONENTS IN X).  P MUST
C                  BE POSITIVE.
C X........ (INPUT/OUTPUT).  ON INPUT, X IS AN INITIAL GUESS AT THE
C                  DESIRED PARAMETER ESTIMATE.  ON OUTPUT, X CONTAINS
C                  THE BEST PARAMETER ESTIMATE FOUND.
C CALCR.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES R(X).  CALCR
C                  MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
C                  IT IS INVOKED BY
C                       CALL CALCR(N,P,X,NF,R,UIPARM,URPARM,UFPARM)
C                  WHEN CALCR IS CALLED, NF IS THE INVOCATION COUNT
C                  FOR CALCR.  IT IS INCLUDED FOR POSSIBLE USE WITH
C                  CALCJ.  IF X IS OUT OF BOUNDS (E.G. IF IT WOULD
C                  CAUSE OVERFLOW IN COMPUTING R(X)), THEN CALCR SHOULD
C                  SET NF TO 0.  THIS WILL CAUSE A SHORTER STEP TO BE
C                  ATTEMPTED.  THE OTHER PARAMETERS ARE AS DESCRIBED
C                  ABOVE AND BELOW.  CALCR SHOULD NOT CHANGE N, P, OR X.
C CALCJ.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES THE JACOBIAN
C                  MATRIX J OF R AT X, I.E., THE N BY P MATRIX WHOSE
C                  (I,K) ENTRY IS THE PARTIAL DERIVATIVE OF THE I-TH
C                  COMPONENT OF R WITH RESPECT TO X(K).  CALCJ MUST BE
C                  DECLARED EXTERNAL IN THE CALLING PROGRAM.  IT IS
C                  INVOKED BY
C                       CALL CALCJ(N,P,X,NF,J,UIPARM,URPARM,UFPARM)
C                  NF IS THE INVOCATION COUNT FOR CALCR AT THE TIME
C                  R(X) WAS EVALUATED.  THE X PASSED TO CALCJ IS
C                  USUALLY THE ONE PASSED TO CALCR ON EITHER ITS MOST
C                  RECENT INVOCATION OR THE ONE PRIOR TO IT.  IF CALCR
C                  SAVES INTERMEDIATE RESULTS FOR USE BY CALCJ, THEN IT
C                  IS POSSIBLE TO TELL FROM NF WHETHER THEY ARE VALID
C                  FOR THE CURRENT X (OR WHICH COPY IS VALID IF TWO
C                  COPIES ARE KEPT).  IF J CANNOT BE COMPUTED AT X,
C                  THEN CALCJ SHOULD SET NF TO 0.  IN THIS CASE, NL2SOL
C                  WILL RETURN WITH IV(1) = 15.  THE OTHER PARAMETERS
C                  TO CALCJ ARE AS DESCRIBED ABOVE AND BELOW.  CALCJ
C                  SHOULD NOT CHANGE N, P, OR X.
C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH AT LEAST
C                  60 + P THAT HELPS CONTROL THE NL2SOL ALGORITHM AND
C                  THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI-
C                  TIES.  OF PARTICULAR INTEREST ARE THE INITIALIZATION/
C                  RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL
C                  PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC-
C                  TION EVALUATIONS.  SEE THE SECTION ON IV INPUT
C                  VALUES BELOW.
C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH AT
C                  LEAST 93 + N*P + 3*N + P*(3*P+33) THAT HELPS CON-
C                  TROL THE NL2SOL ALGORITHM AND THAT IS USED TO STORE
C                  VARIOUS INTERMEDIATE QUANTITIES.  OF PARTICULAR IN-
C                  TEREST ARE THE ENTRIES IN V THAT LIMIT THE LENGTH OF
C                  THE FIRST STEP ATTEMPTED (LMAX0), SPECIFY CONVER-
C                  GENCE TOLERANCES (AFCTOL, RFCTOL, XCTOL, XFTOL),
C                  AND HELP CHOOSE THE STEP SIZE USED IN COMPUTING THE
C                  COVARIANCE MATRIX (DELTA0).  SEE THE SECTION ON
C                  (SELECTED) V INPUT VALUES BELOW.
C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE
C                  TO CALCR AND CALCJ.
C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT
C                  CHANGE TO CALCR AND CALCJ.
C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT
C                  CHANGE TO CALCR AND CALCJ.
C
C  ***  IV INPUT VALUES (FROM SUBROUTINE DFAULT)  ***
C
C IV(1)...  ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 12......
C             0 AND 12 MEAN THIS IS A FRESH START.  0 MEANS THAT
C             DFAULT(IV, V) IS TO BE CALLED TO PROVIDE ALL DEFAULT
C             VALUES TO IV AND V.  12 (THE VALUE THAT DFAULT ASSIGNS TO
C             IV(1)) MEANS THE CALLER HAS ALREADY CALLED DFAULT(IV, V)
C             AND HAS POSSIBLY CHANGED SOME IV AND/OR V ENTRIES TO NON-
C             DEFAULT VALUES.  DEFAULT = 12.
C IV(COVPRT)... IV(14) = 1 MEANS PRINT A COVARIANCE MATRIX AT THE SOLU-
C             TION.  (THIS MATRIX IS COMPUTED JUST BEFORE A RETURN WITH
C             IV(1) = 3, 4, 5, 6.)
C             IV(COVPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(COVREQ)... IV(15) = NONZERO MEANS COMPUTE A COVARIANCE MATRIX
C             JUST BEFORE A RETURN WITH IV(1) = 3, 4, 5, 6.  IN
C             THIS CASE, AN APPROXIMATE COVARIANCE MATRIX IS OBTAINED
C             IN ONE OF SEVERAL WAYS.  LET K = ABS(IV(COVREQ)) AND LET
C             SCALE = 2*F(X)/MAX(1,N-P),  WHERE 2*F(X) IS THE RESIDUAL
C             SUM OF SQUARES.  IF K = 1 OR 2, THEN A FINITE-DIFFERENCE
C             HESSIAN APPROXIMATION H IS OBTAINED.  IF H IS POSITIVE
C             DEFINITE (OR, FOR K = 3, IF THE JACOBIAN MATRIX J AT X
C             IS NONSINGULAR), THEN ONE OF THE FOLLOWING IS COMPUTED...
C                  K = 1....  SCALE * H**-1 * (J**T * J) * H**-1.
C                  K = 2....  SCALE * H**-1.
C                  K = 3....  SCALE * (J**T * J)**-1.
C             (J**T IS THE TRANSPOSE OF J, WHILE **-1 MEANS INVERSE.)
C             IF IV(COVREQ) IS POSITIVE, THEN BOTH FUNCTION AND GRAD-
C             IENT VALUES (CALLS ON CALCR AND CALCJ) ARE USED IN COM-
C             PUTING H (WITH STEP SIZES DETERMINED USING V(DELTA0) --
C             SEE BELOW), WHILE IF IV(COVREQ) IS NEGATIVE, THEN ONLY
C             FUNCTION VALUES (CALLS ON CALCR) ARE USED (WITH STEP
C             SIZES DETERMINED USING V(DLTFDC) -- SEE BELOW).  IF
C             IV(COVREQ) = 0, THEN NO ATTEMPT IS MADE TO COMPUTE A CO-
C             VARIANCE MATRIX (UNLESS IV(COVPRT) = 1, IN WHICH CASE
C             IV(COVREQ) = 1 IS ASSUMED).  SEE IV(COVMAT) BELOW.
C             DEFAULT = 1.
C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D (SEE REF. 1) SHOULD
C             BE CHOSEN.  IV(DTYPE) .GE. 1 MEANS CHOOSE D AS DESCRIBED
C             BELOW WITH V(DFAC).  IV(DTYPE) .LE. 0 MEANS THE CALLER
C             HAS CHOSEN D AND HAS STORED IT IN V STARTING AT
C             V(94 + 2*N + P*(3*P + 31)/2).  DEFAULT = 1.
C IV(INITS).... IV(25) TELLS HOW THE S MATRIX (SEE REF. 1) SHOULD BE
C             INITIALIZED.  0 MEANS INITIALIZE S TO 0 (AND START WITH
C             THE GAUSS-NEWTON MODEL).  1 AND 2 MEAN THAT THE CALLER
C             HAS STORED THE LOWER TRIANGLE OF THE INITIAL S ROWWISE IN
C             V STARTING AT V(87+2*P).  IV(INITS) = 1 MEANS START WITH
C             THE GAUSS-NEWTON MODEL, WHILE IV(INITS) = 2 MEANS START
C             WITH THE AUGMENTED MODEL (SEE REF. 1).  DEFAULT = 0.
C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS
C             (CALLS ON CALCR, EXCLUDING THOSE USED TO COMPUTE THE CO-
C             VARIANCE MATRIX) ALLOWED.  IF THIS NUMBER DOES NOT SUF-
C             FICE, THEN NL2SOL RETURNS WITH IV(1) = 9.  DEFAULT = 200.
C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C             IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA-
C             TIONS (CALLS ON CALCJ, EXCLUDING THOSE USED TO COMPUTE
C             THE COVARIANCE MATRIX) TO IV(MXITER) + 1.  IF IV(MXITER)
C             ITERATIONS DO NOT SUFFICE, THEN NL2SOL RETURNS WITH
C             IV(1) = 10.  DEFAULT = 150.
C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM-
C             MARY LINES PRINTED (BY ITSMRY).  IV(OUTLEV) = 0 MEANS DO
C             NOT PRINT ANY SUMMARY LINES.  OTHERWISE, PRINT A SUMMARY
C             LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS.  IF IV(OUTLEV)
C             IS POSITIVE, THEN SUMMARY LINES OF LENGTH 117 (PLUS CARRI-
C             AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING...  THE
C             ITERATION AND FUNCTION EVALUATION COUNTS, CURRENT FUNC-
C             TION VALUE (V(F) = HALF THE SUM OF SQUARES), RELATIVE
C             DIFFERENCE IN FUNCTION VALUES ACHIEVED BY THE LATEST STEP
C             (I.E., RELDF = (F0-V(F))/F0, WHERE F0 IS THE FUNCTION
C             VALUE FROM THE PREVIOUS ITERATION), THE RELATIVE FUNCTION
C             REDUCTION PREDICTED FOR THE STEP JUST TAKEN (I.E.,
C             PRELDF = V(PREDUC) / F0, WHERE V(PREDUC) IS DESCRIBED
C             BELOW), THE SCALED RELATIVE CHANGE IN X (SEE V(RELDX)
C             BELOW), THE MODELS USED IN THE CURRENT ITERATION (G =
C             GAUSS-NEWTON, S=AUGMENTED), THE MARQUARDT PARAMETER
C             STPPAR USED IN COMPUTING THE LAST STEP, THE SIZING FACTOR
C             USED IN UPDATING S, THE 2-NORM OF THE SCALE VECTOR D
C             TIMES THE STEP JUST TAKEN (SEE REF. 1), AND NPRELDF, I.E.,
C             V(NREDUC)/F0, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF
C             NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION
C             REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH
C             STPPAR = 0).  IF NPRELDF IS ZERO, EITHER THE GRADIENT
C             VANISHES (AS DOES PRELDF) OR ELSE THE AUGMENTED MODEL
C             IS BEING USED AND ITS HESSIAN IS INDEFINITE (WITH PRELDF
C             POSITIVE).  IF NPRELDF IS NEGATIVE, THEN IT IS THE NEGA-
C             OF THE RELATIVE FUNCTION REDUCTION PREDICTED FOR A STEP
C             COMPUTED WITH STEP BOUND V(LMAX0) FOR USE IN TESTING FOR
C             SINGULAR CONVERGENCE.
C                  IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF MAXIMUM
C             LENGTH 79 (OR 55 IS IV(COVPRT) = 0) ARE PRINTED, INCLUD-
C             ING ONLY THE FIRST 6 ITEMS LISTED ABOVE (THROUGH RELDX).
C             DEFAULT = 1.
C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A
C             FRESH START OR ANY CHANGED V VALUES ON A RESTART.
C             IV(PARPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING
C             IS DONE.  IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING.
C             (SETTING IV(PRUNIT) TO 0 IS THE ONLY WAY TO SUPPRESS THE
C             ONE-LINE TERMINATION REASON MESSAGE PRINTED BY ITSMRY.)
C             DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS).
C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS
C             WELL AS THE CORRESPONDING GRADIENT AND SCALE VECTOR D).
C             IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN-
C             ING.  THESE CONSIST OF THE FUNCTION VALUE (HALF THE SUM
C             OF SQUARES) AT X, V(RELDX) (SEE BELOW), THE NUMBER OF
C             FUNCTION AND GRADIENT EVALUATIONS (CALLS ON CALCR AND
C             CALCJ RESPECTIVELY, EXCLUDING ANY CALLS USED TO COMPUTE
C             THE COVARIANCE), THE RELATIVE FUNCTION REDUCTIONS PREDICT-
C             ED FOR THE LAST STEP TAKEN AND FOR A NEWTON STEP (OR PER-
C             HAPS A STEP BOUNDED BY V(LMAX0) -- SEE THE DESCRIPTIONS
C             OF PRELDF AND NPRELDF UNDER IV(OUTLEV) ABOVE), AND (IF AN
C             ATTEMPT WAS MADE TO COMPUTE THE COVARIANCE) THE NUMBER OF
C             CALLS ON CALCR AND CALCJ USED IN TRYING TO COMPUTE THE
C             COVARIANCE.  IV(STATPR) = 0 MEANS SKIP THIS PRINTING.
C             DEFAULT = 1.
C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D
C             (ON A FRESH START ONLY).  IV(X0PRT) = 0 MEANS SKIP THIS
C             PRINTING.  DEFAULT = 1.
C
C  ***  (SELECTED) IV OUTPUT VALUES  ***
C
C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE....
C             3 = X-CONVERGENCE.  THE SCALED RELATIVE DIFFERENCE BE-
C                  TWEEN THE CURRENT PARAMETER VECTOR X AND A LOCALLY
C                  OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT MOST
C                  V(XCTOL).
C             4 = RELATIVE FUNCTION CONVERGENCE.  THE RELATIVE DIFFER-
C                  ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO-
C                  CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL).
C             5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE
C                  CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD).
C             6 = ABSOLUTE FUNCTION CONVERGENCE.  THE CURRENT FUNCTION
C                  VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE.
C             7 = SINGULAR CONVERGENCE.  THE HESSIAN NEAR THE CURRENT
C                  ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A
C                  STEP OF LENGTH AT MOST V(LMAX0) IS UNLIKELY TO YIELD
C                  A RELATIVE FUNCTION DECREASE OF MORE THAN V(RFCTOL).
C             8 = FALSE CONVERGENCE.  THE ITERATES APPEAR TO BE CONVERG-
C                  ING TO A NONCRITICAL POINT.  THIS MAY MEAN THAT THE
C                  CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL),
C                  V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH
C                  THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT
C                  THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT
C                  THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X.
C             9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON-
C                  VERGENCE (SEE IV(MXFCAL)).
C            10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE
C                  (SEE IV(MXITER)).
C            11 = STOPX RETURNED .TRUE. (EXTERNAL INTERUPT).  SEE THE
C                  USAGE NOTES BELOW.
C            13 = F(X) CANNOT BE COMPUTED AT THE INITIAL X.
C            14 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT
C                  OCCUR).
C            15 = THE JACOBIAN COULD NOT BE COMPUTED AT X (SEE CALCJ
C                  ABOVE).
C            16 = N OR P (OR PARAMETER NN TO NL2ITR) OUT OF RANGE --
C                  P .LE. 0 OR N .LT. P OR NN .LT. N.
C            17 = RESTART ATTEMPTED WITH N OR P (OR PAR. NN TO NL2ITR)
C                  CHANGED.
C            18 = IV(INITS) IS OUT OF RANGE.
C            19...45 = V(IV(1)-18) IS OUT OF RANGE.
C            50 = IV(1) WAS OUT OF RANGE.
C            87...(86+P) = JTOL(IV(1)-86) (I.E., V(IV(1)) IS NOT
C                  POSITIVE (SEE V(DFAC) BELOW).
C IV(COVMAT)... IV(26) TELLS WHETHER A COVARIANCE MATRIX WAS COMPUTED.
C             IF (IV(COVMAT) IS POSITIVE, THEN THE LOWER TRIANGLE OF
C             THE COVARIANCE MATRIX IS STORED ROWWISE IN V STARTING AT
C             V(IV(COVMAT)).  IF IV(COVMAT) = 0, THEN NO ATTEMPT WAS
C             MADE TO COMPUTE THE COVARIANCE.  IF IV(COVMAT) = -1,
C             THEN THE FINITE-DIFFERENCE HESSIAN WAS INDEFINITE.  AND
C             AND IF IV(COVMAT) = -2, THEN A SUCCESSFUL FINITE-DIFFER-
C             ENCING STEP COULD NOT BE FOUND FOR SOME COMPONENT OF X
C             (I.E., CALCR SET NF TO 0 FOR EACH OF TWO TRIAL STEPS).
C             NOTE THAT IV(COVMAT) IS RESET TO 0 AFTER EACH SUCCESSFUL
C             STEP, SO IF SUCH A STEP IS TAKEN AFTER A RESTART, THEN
C             THE COVARIANCE MATRIX WILL BE RECOMPUTED.
C IV(D)........ IV(27) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
C             SCALE VECTOR D.
C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
C             LEAST-SQUARES GRADIENT VECTOR (J**T)*R.
C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCR (I.E.,
C             FUNCTION EVALUATIONS, INCLUDING THOSE USED IN COMPUTING
C             THE COVARIANCE).
C IV(NFCOV).... IV(40) IS THE NUMBER OF CALLS MADE ON CALCR WHEN
C             TRYING TO COMPUTE COVARIANCE MATRICES.
C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON
C             CALCJ) SO FAR DONE (INCLUDING THOSE USED FOR COMPUTING
C             THE COVARIANCE).
C IV(NGCOV).... IV(41) IS THE NUMBER OF CALLS MADE ON CALCJ WHEN
C             TRYING TO COMPUTE COVARIANCE MATRICES.
C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED.
C IV(R)........ IV(50) IS THE STARTING SUBSCRIPT IN V OF THE RESIDUAL
C             VECTOR R CORRESPONDING TO X.
C
C  ***  (SELECTED) V INPUT VALUES (FROM SUBROUTINE DFAULT)  ***
C
C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.
C             IF NL2SOL FINDS A POINT WHERE THE FUNCTION VALUE (HALF
C             THE SUM OF SQUARES) IS LESS THAN V(AFCTOL), AND IF NL2SOL
C             DOES NOT RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS
C             WITH IV(1) = 6.  DEFAULT = MAX(10**-20, MACHEP**2), WHERE
C             MACHEP IS THE UNIT ROUNDOFF.
C V(DELTA0)... V(44) IS A FACTOR USED IN CHOOSING THE FINITE-DIFFERENCE
C             STEP SIZE USED IN COMPUTING THE COVARIANCE MATRIX WHEN
C             IV(COVREQ) = 1 OR 2.  FOR COMPONENT I, STEP SIZE
C                  V(DELTA0) * MAX(ABS(X(I)), 1/D(I)) * SIGN(X(I))
C             IS USED, WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).
C             (IF THIS STEP RESULTS IN CALCR SETTING NF TO 0, THEN -0.5
C             TIMES THIS STEP IS ALSO TRIED.)  DEFAULT = MACHEP**0.5,
C             WHERE MACHEP IS THE UNIT ROUNDOFF.
C V(DFAC)..... V(41) AND THE D0 AND JTOL ARRAYS (SEE V(D0INIT) AND
C             V(JTINIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN
C             IV(DTYPE) .GT. 0.  (D IS INITIALIZED ACCORDING TO
C             V(DINIT).)  LET D1(I) =
C               MAX(SQRT(JCNORM(I)**2 + MAX(S(I,I),0)), V(DFAC)*D(I)),
C             WHERE JCNORM(I) IS THE 2-NORM OF THE I-TH COLUMN OF THE
C             CURRENT JACOBIAN MATRIX AND S IS THE S MATRIX OF REF. 1.
C             IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) UNLESS
C             D1(I) .LT. JTOL(I), IN WHICH CASE D(I) IS SET TO
C                                MAX(D0(I), JTOL(I)).
C             IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST
C             ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION
C             DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER.
C             DEFAULT = 0.6.
C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE
C             VECTOR D IS INITIALIZED.  DEFAULT = 0.
C V(DLTFDC)... V(40) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
C             COVARIANCE MATRIX WHEN IV(COVREQ) = -1 OR -2.  FOR
C             DIFFERENCES INVOLVING X(I), THE STEP SIZE FIRST TRIED IS
C                       V(DLTFDC) * MAX(ABS(X(I)), 1/D(I)),
C             WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).  (IF
C             THIS STEP IS TOO BIG THE FIRST TIME IT IS TRIED, I.E., IF
C             CALCR SETS NF TO 0, THEN -0.5 TIMES THIS STEP IS ALSO
C             TRIED.)  DEFAULT = MACHEP**(1/3), WHERE MACHEP IS THE
C             UNIT ROUNDOFF.
C V(D0INIT)... V(37), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
C             OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED.  IF
C             V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
C             STORED D0 IN V STARTING AT V(P+87).  DEFAULT = 1.0.
C V(JTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
C             OF THE JTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED.  IF
C             V(JTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
C             STORED JTOL IN V STARTING AT V(87).  DEFAULT = 10**-6.
C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE
C             VERY FIRST STEP THAT NL2SOL ATTEMPTS.  IT IS ALSO USED
C             IN TESTING FOR SINGULAR CONVERGENCE -- IF THE FUNCTION
C             REDUCTION PREDICTED FOR A STEP OF LENGTH BOUNDED BY
C             V(LMAX0) IS AT MOST V(RFCTOL) * ABS(F0), WHERE  F0  IS
C             THE FUNCTION VALUE AT THE START OF THE CURRENT ITERATION,
C             AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, OR 6,
C             THEN IT RETURNS WITH IV(1) = 7.    DEFAULT = 100.
C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE.
C             IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION
C             REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) AT
C             THE START OF THE CURRENT ITERATION, WHERE  F0  IS THE
C             THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT-
C             ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION
C             DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 4 (OR 5).
C             DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS
C             THE UNIT ROUNDOFF.
C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE
C             AND TO CONSIDER SWITCHING MODELS.  THIS IS DONE IF THE
C             ACTUAL FUNCTION DECREASE FROM THE CURRENT STEP IS NO MORE
C             THAN V(TUNER1) TIMES ITS PREDICTED VALUE.  DEFAULT = 0.1.
C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE.  IF A NEWTON STEP
C             (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL)
C             AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC-
C             TION DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 3 (OR 5).
C             (SEE THE DESCRIPTION OF V(RELDX) BELOW.)
C             DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF.
C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE.  IF A STEP IS
C             TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT-
C             ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL),
C             AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR
C             7, THEN IT RETURNS WITH IV(1) = 8.  (SEE THE DESCRIPTION
C             OF V(RELDX) BELOW.)  DEFAULT = 100*MACHEP, WHERE
C             MACHEP IS THE UNIT ROUNDOFF.
C V(*)........ DFAULT SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH
C             WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER.  SEE
C             VERSION 2.2 OF THE NL2SOL USAGE SUMMARY (WHICH IS AN
C             APPENDIX TO REF. 1).
C
C  ***  (SELECTED) V OUTPUT VALUES  ***
C
C V(DGNORM)... V(1) IS THE 2-NORM OF (D**-1)*G, WHERE G IS THE MOST RE-
C             CENTLY COMPUTED GRADIENT AND D IS THE CORRESPONDING SCALE
C             VECTOR.
C V(DSTNRM)... V(2) IS THE 2-NORM OF D*STEP, WHERE STEP IS THE MOST RE-
C             CENTLY COMPUTED STEP AND D IS THE CURRENT SCALE VECTOR.
C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE (HALF THE SUM OF
C             SQUARES).
C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT
C             ITERATION.
C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION
C             POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC-
C             TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E.,
C             STEP = -H**-1 * G,  WHERE  G = (J**T) * R  IS THE CURRENT
C             GRADIENT AND H IS THE CURRENT HESSIAN APPROXIMATION --
C             H = (J**T)*J  FOR THE GAUSS-NEWTON MODEL AND
C             H = (J**T)*J + S  FOR THE AUGMENTED MODEL).
C                  V(NREDUC) = ZERO MEANS H IS NOT POSITIVE DEFINITE.
C                  IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF
C             THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH
C             A STEP BOUND OF V(LMAX0) FOR USE IN TESTING FOR SINGULAR
C             CONVERGENCE.
C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT
C             QUADRATIC MODEL) FOR THE CURRENT STEP.  THIS (DIVIDED BY
C             V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION
C             CONVERGENCE.
C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE
C             CURRENT STEP, COMPUTED AS
C                  MAX(ABS(D(I)*(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             WHERE X = X0 + STEP.
C
C-------------------------------  NOTES  -------------------------------
C
C  ***  ALGORITHM NOTES  ***
C
C        SEE REF. 1 FOR A DESCRIPTION OF THE ALGORITHM USED.
C        ON PROBLEMS WHICH ARE NATURALLY WELL SCALED, BETTER PERFORM-
C     ANCE MAY BE OBTAINED BY SETTING V(D0INIT) = 1.0 AND IV(DTYPE) = 0,
C     WHICH WILL CAUSE THE SCALE VECTOR D TO BE SET TO ALL ONES.
C
C  ***  USAGE NOTES  ***
C
C        AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART,
C     I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE
C     AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT-
C     ED.  IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV
C     AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DFAULT).
C        THOSE WHO DO NOT WISH TO WRITE A CALCJ WHICH COMPUTES THE JA-
C     COBIAN MATRIX ANALYTICALLY SHOULD CALL NL2SNO RATHER THAN NL2SOL.
C     NL2SNO USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE JACOBIAN.
C        THOSE WHO WOULD PREFER TO PROVIDE R AND J (THE RESIDUAL AND
C     JACOBIAN) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU-
C     TINES CALCR AND CALCJ MAY CALL ON NL2ITR DIRECTLY.  SEE THE COM-
C     MENTS AT THE BEGINNING OF NL2ITR.
C        THOSE WHO USE NL2SOL INTERACTIVELY MAY WISH TO SUPPLY THEIR
C     OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY
C     HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED.  THIS MAKES IT POS-
C     SIBLE TO EXTERNALLY INTERRUPT NL2SOL (WHICH WILL RETURN WITH
C     IV(1) = 11 IF STOPX RETURNS .TRUE.).
C        STORAGE FOR J IS ALLOCATED AT THE END OF V.  THUS THE CALLER
C     MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCJ TO USE
C     ELEMENTS OF J BEYOND THE FIRST N*P AS SCRATCH STORAGE.
C
C  ***  PORTABILITY NOTES  ***
C
C        THE NL2SOL DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE-
C     PRECISION VERSIONS OF THE NL2SOL SOURCE CODE, SO IT SHOULD BE UN-
C     NECESSARY TO CHANGE PRECISIONS.
C        ONLY THE FUNCTIONS IMDCON AND RMDCON CONTAIN MACHINE-DEPENDENT
C     CONSTANTS.  TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD
C     SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS.
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 TRANS.
C             MATH. SOFTWARE.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY (WINTER 1979 - WINTER 1980).
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----------------------------  DECLARATIONS  ---------------------------
C
C     EXTERNAL ITSMRY, NL2ITR
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO-
C             RITHM.
C
C     LOGICAL STRTED
C     INTEGER D1, J1, NF, R1
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER D, J, NFCALL, NFGCAL, R, TOOBIG
C
C  ***  IV SUBSCRIPT VALUES  ***
C
      DATA NFCALL/6/, NFGCAL/7/, TOOBIG/2/
C
C  ***  V SUBSCRIPT VALUES  ***
C
      DATA D/27/, J/33/, R/50/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      D1 = 94 + 2*N + P*(3*P + 31)/2
      IV(D) = D1
      R1 = D1 + P
      IV(R) = R1
      J1 = R1 + N
      IV(J) = J1
      STRTED = .TRUE.
      IF (IV(1) .NE. 0 .AND. IV(1) .NE. 12) GO TO 40
         STRTED = .FALSE.
         IV(NFCALL) = 1
         IV(NFGCAL) = 1
C
 10   NF = IV(NFCALL)
      CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
      IF (STRTED) GO TO 20
         IF (NF .GT. 0) GO TO 30
              IV(1) = 13
              GO TO 60
C
 20   IF (NF .LE. 0) IV(TOOBIG) = 1
      GO TO 40
C
 30   CALL CALCJ(N, P, X, IV(NFGCAL), V(J1), UIPARM, URPARM, UFPARM)
      IF (IV(NFGCAL) .EQ. 0) GO TO 50
      STRTED = .TRUE.
C
 40   CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X)
      IF (IV(1) - 2) 10, 30, 999
C
 50   IV(1) = 15
 60   CALL ITSMRY(V(D1), IV, P, V, X)
C
 999  RETURN
C  ***  LAST CARD OF NL2SOL FOLLOWS  ***
      END
*NL2X
      SUBROUTINE NL2X
C     ***  TEST NL2SOL AND NL2SNO ON MADSEN EXAMPLE  ***
C
C  VARIABLE DECLARATIONS
C
C  LOCAL ARRAYS
      REAL
     +   URPARM(1),V(147),X(2)
      INTEGER
     +   IV(62),UIPARM(1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL MADJ,MADR,NL2SNO,NL2SOL,UFPARM
C
      X(1) = 3.0E0
      X(2) = 1.0E0
      IV(1) = 0
      CALL NL2SOL(3, 2, X, MADR, MADJ, IV, V, UIPARM, URPARM, UFPARM)
      IV(1) = 12
      X(1) = 3.0E0
      X(2) = 1.0E0
      CALL NL2SNO(3, 2, X, MADR, IV, V, UIPARM, URPARM, UFPARM)
      RETURN
      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
      REAL
     +   COND,RSD,RSS,RSSHLF,YSS
      INTEGER
     +   IDF,LVCVL,LWT,N,NNZW,NPAR,NPARE
      LOGICAL
     +   EXACT,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   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
      REAL
     +   FAC,FPLM,RVAR,SM,TJ,WTI,WTSUM,YWTSM,YWTYSM
      INTEGER
     +   I,J,JK,K
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FITEXT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL COND
C        THE CONDITION NUMBER OF D.
C     REAL 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     REAL FAC
C        A FACTOR USED TO CORRECT FOR ZERO WEIGHTED OBSERVATIONS IN
C        THE VARIANCE COVARIANCE COMPUTATION.
C     REAL 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     REAL PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     REAL RD(N)
C        THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R
C        FACTORIZATION OF D.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL RSSHLF
C        HALF THE RESIDUAL SUM OF SQUARES.
C     REAL RVAR
C        THE RESIDUAL VARIANCE.
C     REAL SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL SM
C        A VARIABLE USED FOR SUMMATION.
C     REAL TJ
C        ...
C     REAL 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL WTI
C        THE ACTUAL WEIGHT USED FOR THE ITH OBSERVATION.
C     REAL WTSUM
C        THE SUM OF THE WEIGHTS.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C     REAL YSS
C        THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE.
C     REAL YWTSM
C        THE SUM OF THE VALUES Y(I)*WT(I), I=1,N.
C     REAL YWTYSM
C        THE SUM OF THE VALUES Y(I)*WT(I)*WT(I), I=1,N.
C
      FPLM = R1MACH(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.0E0*RSSHLF
      RVAR = 0.0E0
      IF (IDF.GE.1) RVAR = RSS/IDF
      RSD = SQRT(RVAR)
      YWTSM = 0.0E0
      YWTYSM = 0.0E0
      WTSUM = 0.0E0
      DO 20 I=1,N
         WTI = 1.0E0
         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.0E0)
C
      CALL FITEXT(RSS, YSS, EXACT)
C
      COND = FPLM
      IF (RD(NPARE).NE.0.0E0) 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.0E0
         DO 60 J=1,NPARE
            TJ = 0.0E0
            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.0E0) SM = 0.0E0
         SDPVT(I) = SQRT(SM)
C
         SDREST(I) = FPLM
         WTI = 1.0E0
         IF (WEIGHT) WTI = WT(I)
         IF (WTI.EQ.0.0E0) GO TO 90
C
         IF (RVAR/WTI-SM.LE.0.0E0) 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
*NLCNTA
      SUBROUTINE NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR,
     +   RES, LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP,
     +   SCALE, LSCALE, DELTA, IVCVOP, NPRT, RSD, PV, LPV, SDPV, LSDPV,
     +   SDRES, LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLLING SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING ANALYTIC (USER-SUPPLIED) DERIVATIVES.
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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IVCV,IVCVOP,IXM,LDSTAK,LIFIXD,LPV,LSCALE,LSDPV,
     +   LSDRES,LWT,M,MIT,N,NNZW,NPAR,NPARE,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),VCV(*),WT(*),
     +   XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   ISUBHD,LDSMIN,LSTP,NDIGIT,NETA,NROW,NTAU
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,PRTFXD,WIDE
C
C  LOCAL ARRAYS
      REAL
     +   STP(1)
      INTEGER
     +   IPTOUT(5)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   ICNTI
      EXTERNAL ICNTI
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DCKCNT,LDSCMP,NLCNT,NLDRVA,NLER,NLHDRA,PRTCNT,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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     REAL 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 IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE
C        TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 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 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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
C     INTEGER IPTOUT(5)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV.
C     INTEGER IVCVOP
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED
C        TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE
C        IVCVOP LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED
C        IVCVOP EQ 1 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        IVCVOP 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        IVCVOP EQ 3 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        IVCVOP EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVCVOP EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVCVOP EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVCVOP GE 7 INDICATES THE DEFAULT OPTION WILL BE USED
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
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 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 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 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     EXTERNAL NLDRVA
C        THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES.
C     EXTERNAL NLHDRA
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
C     INTEGER NTAU
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICALLY APPROXIMATED DERIVATIVES AND THE USER SUPPLIED
C        DRVITIVES.
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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE 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     REAL PV(LPV)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(LSCALE)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL 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     REAL STP(1)
C        THE DUMMY STEP SIZE ARRAY.
C     REAL 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     REAL WT(LWT)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET VARIOUS PROGRAM VALUES
C
      HLFRPT = .FALSE.
      APRXDV = .FALSE.
      PRTFXD = .TRUE.
      STP(1) = 0.0E0
      LSTP = 1
      NETA = 0
      NTAU = 0
      NROW = 0
C
      WIDE = .TRUE.
      PAGE = .FALSE.
C
      NDIGIT = 5
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      IF ((IFIXED(1).GE.0) .AND. (NPAR.GE.1)) THEN
         NPARE = ICNTI(IFIXED,NPAR,0)
      ELSE
         NPARE = NPAR
      END IF
C
      CALL LDSCMP(6, 0, 60+2*NPAR, 0, 0, 0, 'S',
     +            94+N*(3+NPAR)+NPARE*(3*NPARE+35)/2, LDSMIN)
C
      CALL NLER (NMSUB, WEIGHT, WT, LWT, N, M, IXM,
     +   IFIXED, LIFIXD, NPAR, NPARE,
     +   LDSTAK, LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, NNZW)
C
      IF (IERR.NE.0) RETURN
C
      CALL STKSET(LDSTAK, 4)
C
C     SET PRINT CONTROL VALUES
C
      CALL PRTCNT(NPRT, NDIGIT, IPTOUT)
C
      IF (IDRVCK.EQ.0) GO TO 10
C
C     CHECK DERIVATIVES, IF DESIRED
C
      ISUBHD = 1
      CALL DCKCNT(XM, N, M, IXM, MDL, DRV, PAR, NPAR, NETA, NTAU,
     +   SCALE, LSCALE, NROW, IPTOUT(1), NLHDRA, PAGE, WIDE, ISUBHD,
     +   HLFRPT, PRTFXD, IFIXED, LIFIXD)
C
C     CHECK FOR DEFINITE ERROR IN DERIVATIVES
C
      IF (IERR.LE.2) GO TO 10
      IERR = 1
      RETURN
C
   10 CONTINUE
C
      IERR = 0
C
      CALL NLCNT(Y, WT, LWT, XM, N, M, IXM, MDL, NLDRVA, APRXDV, DRV,
     +   PAR, NPAR, RES, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP,
     +   SCALE, LSCALE, DELTA, IVCVOP, RSD, PV, LPV, SDPV, LSDPV,
     +   SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW, NPARE, NLHDRA,
     +   PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT)
C
      RETURN
C
      END
*NLCNT
      SUBROUTINE NLCNT(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)
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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IVCV,IXM,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,M,
     +   MIT,N,NDIGIT,NNZW,NPAR,NPARE
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,SAVE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*),
     +   WT(*),XM(*),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,
     +   RWORK,SDPVI,SDRESI,VCVL
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CPYASF,CPYVII,NLMN,SCOPY,SETIV,STKCLR
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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     REAL 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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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 REAL 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     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     REAL 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     REAL 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     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER RWORK
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE REAL 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     REAL SCALE(LSCALE)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL 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     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     INTEGER SDRESI
C        THE STARTING LOCATION IN RWORK OF THE
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL 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     REAL STP(LSTP)
C        THE STEP SIZE ARRAY.
C     REAL 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     REAL WT(LWT)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET VARIOUS PROGRAM VALUES
C
      NALL0 = STKST(1)
C
      IFP = 3
C
      IERR = 0
C
C     SUBDIVIDE WORK AREA FOR LEAST SQUARES ANALYSIS
C
      IIWORK = NPARE + 60
      IRWORK = 94 + 2*N + NPARE*(3*NPARE+33)/2
C
      IFIXD = STKGET(NPAR,2)
      IWORK = STKGET(IIWORK,2)
C
      D = STKGET(N*NPAR,IFP)
      PARE = STKGET(NPARE,IFP)
      PVI = STKGET(N,IFP)
      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 NLMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, MDL, NLDRV,
     +   APRXDV, DRV, ISTAK(IFIXD), PAR, RSTAK(PARE), NPAR, RES, PAGE,
     +   WIDE, HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE,
     +   DELTA, IVAPRX, IPTOUT, NDIGIT, RSD, RSTAK(PVI), SDPVI,
     +   SDRESI, VCVL, LVCVL, RSTAK(D), ISTAK(IWORK), IIWORK,
     +   RSTAK(RWORK), IRWORK, NLHDR, NPARE)
C
      IF (.NOT.SAVE) GO TO 10
C
      SDPVI = RWORK + SDPVI - 1
      SDRESI = RWORK + SDRESI - 1
      VCVL = RWORK + VCVL - 1
C
      CALL SCOPY(N, RSTAK(PVI), 1, PV, 1)
      CALL SCOPY(N, RSTAK(SDPVI), 1, SDPV, 1)
      CALL SCOPY(N, RSTAK(SDRESI), 1, SDRES, 1)
      CALL CPYASF(NPARE, RSTAK(VCVL), LVCVL, VCV, IVCV)
C
   10 CALL STKCLR(NALL0)
C
      RETURN
C
      END
*NLCNTN
      SUBROUTINE NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVCVOP, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, 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  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVCV,IVCVOP,IXM,LDSTAK,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,
     +   LSTP,LWT,M,MIT,N,NNZW,NPAR,NPARE,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*),
     +   WT(*),XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   EXMPT
      INTEGER
     +   IFP,IS,ISUBHD,LDSMIN,NALL0,NDIGIT,NETA,STPI
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,PRTFXD,WIDE
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   IPTOUT(5),ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   ICNTI,STKGET,STKST
      EXTERNAL ICNTI,STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DRV,LDSCMP,NLCNT,NLDRVN,NLER,NLHDRN,PRTCNT,SCOPY,STKCLR,
     +   STKSET,STPCNT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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     REAL 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     REAL 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 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 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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
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 INTEGER VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV.
C     INTEGER IVCVOP
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED
C        TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE
C        IVCVOP LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED
C        IVCVOP EQ 1 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        IVCVOP 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        IVCVOP EQ 3 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        IVCVOP EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVCVOP EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVCVOP EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVCVOP GE 7 INDICATES THE DEFAULT OPTION WILL BE USED
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
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 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 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     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
C     EXTERNAL NLDRVN
C        THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES.
C     EXTERNAL NLHDRN
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE 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     REAL PV(LPV)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
C     REAL RSTAK(12)
C        THE REAL 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     REAL SCALE(LSCALE)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     REAL 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     REAL 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     REAL STP(LSTP)
C        THE STEP SIZE ARRAY.
C     INTEGER STPI
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE STEP SIZE ARRAY.
C     REAL 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     REAL WT(LWT)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET VARIOUS PROGRAM VALUES
C
      HLFRPT = .FALSE.
      APRXDV = .TRUE.
      PRTFXD = .TRUE.
      EXMPT = -1.0E0
      NETA = 0
C
      WIDE = .TRUE.
      PAGE = .FALSE.
C
      NDIGIT = 5
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      IF ((IFIXED(1).GE.0) .AND. (NPAR.GE.1)) THEN
         NPARE = ICNTI(IFIXED,NPAR,0)
      ELSE
         NPARE = NPAR
      END IF
C
      IF (STP(1).LE.0.0E0) THEN
         IS = 1
      ELSE
         IS = 0
      END IF
C
      CALL LDSCMP(14, 0, MAX(IS*2*(N+NPAR),60+NPAR+NPARE), 0, 0, 0,
     +   'S',
     +   MAX(IS*(9*N+MAX(N,NPAR)),94+N*(3+NPAR)+NPARE*(3*NPARE+37)/2),
     +   LDSMIN)
C
      CALL NLER (NMSUB, WEIGHT, WT, LWT, N, M, IXM,
     +   IFIXED, LIFIXD, NPAR, NPARE,
     +   LDSTAK, LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, NNZW)
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 = 3
C
      STPI = STKGET(NPAR,IFP)
C
C     COPY SUPPLIED STEP SIZES TO WORK SPACE
C
      CALL SCOPY(LSTP, STP, 1, RSTAK(STPI), 1)
C
      IF (IERR.NE.0) GO TO 10
C
C     SELECT STEP SIZES, IF DESIRED
C
      ISUBHD = 1
C
      IF (STP(1).LE.0.0E0) CALL STPCNT(XM, N, M, IXM, MDL, PAR, NPAR,
     +   RSTAK(STPI), EXMPT, NETA, SCALE, LSCALE, IPTOUT(1), NLHDRN,
     +   PAGE, WIDE, ISUBHD, HLFRPT, PRTFXD, IFIXED, LIFIXD)
C
      CALL NLCNT(Y, WT, LWT, XM, N, M, IXM, MDL, NLDRVN, APRXDV, DRV,
     +   PAR, NPAR, RES, IFIXED, LIFIXD, RSTAK(STPI), NPAR, MIT,
     +   STOPSS, STOPP, SCALE, LSCALE, DELTA, IVCVOP, RSD, PV, LPV,
     +   SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW,
     +   NPARE, NLHDRN, PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT)
C
   10 CONTINUE
C
      CALL STKCLR(NALL0)
C
      RETURN
C
      END
*NLDRVA
      SUBROUTINE NLDRVA (MDL, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M,
     +   IXM, PV, D, WEIGHT, WT, LWT, STP, LSTP, SCL, LSCL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE ANALYTIC DERIVATIVE MATRIX (JACOBIAN)
C     USING USER-SUPPLIED ROUTINE DERIV.
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,LSTP,LWT,M,N,NPAR
      LOGICAL
     +   DONE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   D(N,NPAR),PAR(NPAR),PV(N),SCL(LSCL),STP(LSTP),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
      REAL
     +   WTSQRT
      INTEGER
     +   I,J,JPK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL D(N,NPAR)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
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 INDEXING VARIABLE.
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER JPK
C        THE INDEX OF THE PACKED PARAMETERS.
C     INTEGER LSCL
C        THE ACTUAL LENGTH OF THE VECTOR SCL.
C     INTEGER LSTP
C        THE ACTUAL LENGTH OF THE VECTOR STP.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(N)
C        THE PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL SCL(LSCL)
C        THE SCALE VALUES.
C     REAL STP(LSTP)
C        THE SELECTED RELATIVE STEP SIZES.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL WTSQRT
C        THE SQUARE ROOT OF THE ITH WEIGHT.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
C     COMPUTE JACOBIAN
C
      CALL DRV(PAR, NPAR, XM, N, M, IXM, D)
C
      JPK = 0
C
      DO 20 J=1,NPAR
         IF (IFIXD(J).NE.0) GO TO 20
         JPK = JPK + 1
         DO 10 I=1,N
            WTSQRT = 1.0E0
            IF (WEIGHT .AND. (.NOT.DONE)) WTSQRT = SQRT(WT(I))
            D(I,JPK) = -WTSQRT*D(I,J)
   10    CONTINUE
   20 CONTINUE
C
      RETURN
C
      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
      REAL
     +   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
      REAL
     +   PJ,STPJ,WTSQRT
      INTEGER
     +   I,J,JPK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SIGN,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PJ
C        A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER.
C     REAL PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     REAL SCL(LSCL)
C        THE SCALE VALUES.
C     REAL STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     REAL 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL WTSQRT
C        THE SQUARE ROOT OF THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
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.0E0) THEN
               IF (PAR(J).NE.0.0E0) THEN
                  STPJ = STPT(J)*SIGN(1.0E0,PAR(J))*ABS(PAR(J))
               ELSE
                  STPJ = STPT(J)
               END IF
            ELSE
               STPJ = STPT(J)*
     +                SIGN(1.0E0,PAR(J))*MAX(ABS(PAR(J)),1.0E0/
     +                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.0E0
               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
*NLER
      SUBROUTINE NLER (NMSUB, WEIGHT, WT, LWT, N, M, IXM,
     +   IFIXED, LIFIXD, NPAR, NPARE,
     +   LDSTAK, LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, NNZW)
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  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IVCV,IXM,LDSMIN,LDSTAK,LIFIXD,LSCALE,LSTP,LWT,M,N,NNZW,
     +   NPAR,NPARE
      LOGICAL
     +   SAVE,WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   SCALE(*),STP(*),WT(*)
      INTEGER
     +   IFIXED(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,NFIX,NNFIX,NV,NZW
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERROR(20)
      CHARACTER
     +   LIFIX(8)*1,LIVCV(8)*1,LIXM(8)*1,LLDS(8)*1,LM(8)*1,
     +   LN(8)*1,LNPAR(8)*1,LNPARE(8)*1,LONE(8)*1,LSCL(8)*1,
     +   LSTEP(8)*1,LWGT(8)*1,LZERO(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EIVEQ,ERVGT,ERVWT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
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        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 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 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.  IF
C        IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED.  IF
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
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
C    +   LIFIX(8), LIVCV(8), LIXM(8), LLDS(8), LM(8), LN(8), LNPAR(8),
C    +   LNPARE(8), LONE(8), LSCL(8), LSTEP(8), LWGT(8), LZERO(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER LSCALE
C        THE ACTUAL LENGTH OF THE VECTOR SCALE.
C     INTEGER LSTP
C        THE ACTUAL LENGTH OF THE VECTOR STP.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NZW
C        THE NUMBER OF ZERO WEIGHTS.
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     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL STP(LSTP)
C        THE STEP SIZE ARRAY.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C
C
C     SET UP NAME ARRAYS
C
      DATA LIFIX(1), LIFIX(2), LIFIX(3), LIFIX(4), LIFIX(5),
     +   LIFIX(6), LIFIX(7), LIFIX(8) /'I','F','I','X','E','D',' ',' '/
      DATA LIVCV(1), LIVCV(2), LIVCV(3), LIVCV(4), LIVCV(5),
     +   LIVCV(6), LIVCV(7), LIVCV(8) /'I','V','C','V',' ',' ',' ',' '/
      DATA LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6),
     +   LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      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) /'O','N','E',' ',' ',' ',' ',' '/
      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 LWGT(1), LWGT(2), LWGT(3), LWGT(4), LWGT(5),
     +   LWGT(6), LWGT(7), LWGT(8) /'W','T',' ',' ',' ',' ',' ',' '/
      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.
      NNZW = N
C
      CALL EISGE(NMSUB, LNPAR, NPAR, 1, 2, HEAD, ERROR(1), LONE)
      IF (ERROR(1)) THEN
        ERROR(7) = .TRUE.
      ELSE
        IF (IFIXED(1).LT.0) THEN
          CALL EISGE(NMSUB, LN, N, NPAR, 2, HEAD, ERROR(7), LNPAR)
          IF (WEIGHT) THEN
            CALL ERVWT(NMSUB, LWGT, WT, LWT, NPAR, HEAD, NNZW,
     +                 NZW, 2, ERROR(3), LNPAR)
          END IF
        ELSE
          CALL EIVEQ(NMSUB, LIFIX, IFIXED, NPAR, 0, 1, HEAD, NNFIX,
     +               NFIX, 1, ERROR(2), LZERO, LONE)
          IF (.NOT.ERROR(2)) THEN
            CALL EISGE(NMSUB, LN, N, NPARE, 2, HEAD, ERROR(7), LNPARE)
            IF (WEIGHT) THEN
              CALL ERVWT(NMSUB, LWGT, WT, LWT, NPARE, HEAD, NNZW,
     +                   NZW, 2, ERROR(3), LNPARE)
            END IF
          END IF
        END IF
      END IF
C
      CALL EISGE(NMSUB, LM, M, 1, 2, HEAD, ERROR(4), LONE)
C
      IF (.NOT.ERROR(7))
     +   CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(5), LN)
C
C
      IF (.NOT.ERROR(1)) THEN
         IF ((.NOT.ERROR(2)) .AND. (.NOT.ERROR(7)))
     +      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(6),
     +      LLDS)
C
         CALL ERVGT(NMSUB, LSTEP, STP, LSTP, 0.0E0, 0, HEAD, 6, NV,
     +      ERROR(8), LZERO)
C
         CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 0, HEAD, 6, NV,
     +      ERROR(12), LZERO)
C
         IF (SAVE)
     +      CALL EISGE(NMSUB, LIVCV, IVCV, NPARE, 3, HEAD, ERROR(15),
     +      LNPARE)
      END IF
C
C
      DO 20 I=1,20
         IF (ERROR(I)) GO TO 30
   20 CONTINUE
      RETURN
C
   30 CONTINUE
      IERR = 1
      RETURN
C
      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
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     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
*NLFIN
      SUBROUTINE NLFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD,
     +   PAR, NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RSSHLF, RSD,
     +   PV, SDPV, SDRES, RD, VCVL, LVCVL, D, NLHDR, IVCVPT, ISKULL)
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     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
      REAL
     +   RSD,RSSHLF
      INTEGER
     +   IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE
      LOGICAL
     +   PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   D(N,NPAR),PAR(NPAR),PV(N),RD(NPARE),RES(N),SDPV(N),SDRES(N),
     +   VCVL(LVCVL),WT(LWT),XM(IXM,M),Y(N)
      INTEGER
     +   IFIXD(NPAR),IPTOUT(NDIGIT),ISKULL(10)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL NLHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   COND,RSS,YSS
      INTEGER
     +   IDF
      LOGICAL
     +   EXACT,PRTFSM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL NLCMP,NLOUT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL COND
C        THE CONDITION NUMBER OF D.
C     REAL D(N,NPAR)
C        THE 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     INTEGER IDF
C        THE DEGREES OF FREEDOM IN THE FIT.
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) HAVE BEEN HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) HAVE BEEN 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(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                       *INVERSE(HESSIAN)
C        IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)
C        IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
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 N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE
C        PARAMETERS ARE STORED.
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 PRTFSM
C        THE VARIABLE USED TO INDICATE WHETHER ANY OF THE SUMMARY
C        INFORMATION IS TO BE PRINTED (TRUE) OR NOT (FALSE).
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RD(NPARE)
C        THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R
C        FACTORIZATION OF D.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSSHLF
C        HALF THE RESIDUAL SUM OF SQUARES.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL VCVL(LVCVL)
C        THE LOWER HALF OF THE 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C     REAL YSS
C        THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y.
C
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, PV, SDPV, SDRES, 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 NLOUT(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM,
     +   IFIXD, PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND,
     +   RSS, RSD, YSS, EXACT, PV, SDPV, SDRES, VCVL, LVCVL, IVCVPT,
     +   ISKULL, NLHDR, WIDE)
      RETURN
C
      END
*NLHDRA
      SUBROUTINE NLHDRA(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 THAT USE ANALYTIC
C     (USER-SUPPLIED) DERIVATIVES.
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
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT, 1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT, 1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT (35H+NONLINEAR LEAST SQUARES ESTIMATION,
     +   42H WITH USER-SUPPLIED DERIVATIVES, CONTINUED)
 1010 FORMAT ('+', 71(1H*)/
     +   1X, 37H*  NONLINEAR LEAST SQUARES ESTIMATION,
     +   34H WITH USER-SUPPLIED DERIVATIVES  */ 1X, 71(1H*))
 1020 FORMAT ('1')
 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-'))
      END
*NLHDRN
      SUBROUTINE NLHDRN(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 THAT USE NUMERICAL
C     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  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT, 1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT, 1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT (35H+NONLINEAR LEAST SQUARES ESTIMATION,
     +   53H WITH NUMERICALLY APPROXIMATED DERIVATIVES, CONTINUED)
 1010 FORMAT ('+', 82(1H*)/
     +   1X, 37H*  NONLINEAR LEAST SQUARES ESTIMATION,
     +   45H WITH NUMERICALLY APPROXIMATED DERIVATIVES  */ 1X, 82(1H*))
 1020 FORMAT ('1')
 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-'))
      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
      REAL
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IIWORK,IRWORK,IVAPRX,IVCVPT,LSCALE,MIT,N,NPAR,NPARE,SCL
      LOGICAL
     +   APRXDV
C
C  ARRAY ARGUMENTS
      REAL
     +   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
      REAL
     +   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
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     REAL 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.0E0
C        INIDCATES NO, AND THE VALUE RWORK(DINIT) = -1.0E0 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 REAL 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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL 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     REAL RWORK(IRWORK)
C        THE REAL WORK VECTOR USED BY THE NL2 SUBROUTINES.
C     REAL 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     REAL 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     REAL 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     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.0E0) .AND. (STOPP.LE.1.0E0))
     +   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.0E0) 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.0E0) RWORK(SCLJ) = 1.0E0
         IF (PAR(J).NE.0.0E0) RWORK(SCLJ) = 1.0E0/ABS(PAR(J))
   30 CONTINUE
C
      GO TO 60
C
   40 IWORK(DTYPE) = 0
      RWORK(DINIT) = -1.0E0
      SCLJ = SCL - 1
      DO 50 J=1,NPAR
         IF (IFIXD(J).NE.0) GO TO 50
         SCLJ = SCLJ + 1
         RWORK(SCLJ) = 1.0E0/MAX(ABS(SCALE(J)),ABS(PAR(J)))
   50 CONTINUE
C
   60 IF (DELTA.LE.0.0E0) RWORK(LMAX0) = 100.0E0
      IF (DELTA.GT.0.0E0) 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
*NLISM
      SUBROUTINE NLISM (NLHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW,
     +   WEIGHT, IFIXD, PAR, SCALE, IWORK, IIWORK, RWORK, IRWORK, RES,
     +   APRXDV, STP, LSTP, 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.
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,IRWORK,LSTP,M,N,NNZW,NPAR,NPARE
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),RES(N),RWORK(IRWORK),SCALE(NPAR),STP(LSTP)
      INTEGER
     +   IFIXD(NPAR),IWORK(IIWORK)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL NLHDR
C
C  LOCAL SCALARS
      REAL
     +   RSD,RSS
      INTEGER
     +   I,IPRT,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL
C
C  EXTERNAL FUNCTIONS
      REAL
     +   SNRM2
      EXTERNAL SNRM2
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC REAL,SQRT
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 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 INDEX VARIABLE
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 REAL WORK VECTOR RWORK.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IWORK(IIWORK)
C        THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES.
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 LSTP
C        THE ACTUAL LENGTH OF THE VECTOR STP.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
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 COVARIANCE
C        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     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 UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        NUMBER OF PARAMETERS ESTIMATED BY ROUTINE.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
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     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     INTEGER RFCTOL
C        THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE
C        TOLERANCE.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION AT THE INITIAL PARAMETER VALUES
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES AT THE INITIAL PARAMETER VALUES
C     REAL RWORK(IRWORK)
C        THE REAL WORK VECTOR USED BY THE NL2 SUBROUTINES.
C     REAL SCALE(NPAR)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C     REAL STP(LSTP)
C        THE SELECTED RELATIVE STEP SIZES.
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        FULL WIDTH (TRUE) OR NOT (FALSE).
C     INTEGER XCTOL
C        THE LOCATION IN RSTAK/DSTAK OF THE P CONVERGENCE TOLERANCE.
C
C     IWORK SUBSCRIPT VALUES
C
      DATA MXFCAL/17/, MXITER/18/
C
C     RWORK SUBSCRIPT VALUES
C
      DATA LMAX0/35/, RFCTOL/32/, XCTOL/33/
C
      CALL IPRINT(IPRT)
C
      IF (.NOT.HLFRPT) THEN
C
         ISUBHD = 1
         CALL NLHDR(PAGE, WIDE, ISUBHD)
C
         IF (APRXDV) THEN
            WRITE (IPRT, 1260)
         ELSE
            WRITE (IPRT, 1270)
         END IF
C
         DO 40 I = 1, NPAR
            IF (IFIXD(I).EQ.0) THEN
               IF (SCALE(1).GT.0.0E0) THEN
                  IF (APRXDV) THEN
                     WRITE (IPRT, 1410) I, PAR(I), SCALE(I), STP(I)
                  ELSE
                     WRITE (IPRT, 1410) I, PAR(I), SCALE(I)
                  END IF
               ELSE
                  IF (APRXDV) THEN
                     WRITE (IPRT, 1310) I, PAR(I), STP(I)
                  ELSE
                     WRITE (IPRT, 1310) I, PAR(I)
                  END IF
               END IF
            ELSE
               IF (APRXDV) THEN
                  WRITE (IPRT, 1510) I, PAR(I)
               ELSE
                  WRITE (IPRT, 1610) I, PAR(I)
               END IF
            END IF
   40    CONTINUE
C
         WRITE (IPRT, 1160) N
C
      END IF
C
      IF (WEIGHT) WRITE (IPRT, 1170) NNZW
      WRITE (IPRT, 1180) M
      WRITE(IPRT, 1070) IWORK(MXITER)
      WRITE(IPRT, 1090) IWORK(MXFCAL)
      WRITE(IPRT, 1080)
      WRITE(IPRT, 1100) RWORK(RFCTOL)
      WRITE(IPRT, 1110) RWORK(XCTOL)
      WRITE(IPRT, 1120) RWORK(LMAX0)
C
      RSD = SNRM2(N, RES, 1)
      RSS = RSD * RSD
      IF (NNZW-NPARE.GE.1) RSD = RSD /SQRT(REAL(NNZW-NPARE))
      WRITE (IPRT, 1200) RSS
      WRITE (IPRT, 1210) RSD
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1070 FORMAT (/37H MAXIMUM NUMBER OF ITERATIONS ALLOWED, 32X, 5H(MIT),
     +   1X, I5)
 1080 FORMAT(/44H CONVERGENCE CRITERION FOR TEST BASED ON THE/)
 1090 FORMAT(/41H MAXIMUM NUMBER OF MODEL SUBROUTINE CALLS,
     +   8H ALLOWED, 26X, I5)
 1100 FORMAT (5X, 39H FORECASTED RELATIVE CHANGE IN RESIDUAL,
     +   15H SUM OF SQUARES, 7X, 8H(STOPSS), 1X, G11.4)
 1110 FORMAT(5X, 49H MAXIMUM SCALED RELATIVE CHANGE IN THE PARAMETERS,
     +   13X, 7H(STOPP), 1X, G11.4)
 1120 FORMAT(//41H MAXIMUM CHANGE ALLOWED IN THE PARAMETERS,
     +   23H AT THE FIRST ITERATION, 3X, 7H(DELTA), 1X, G11.4)
 1160 FORMAT (/23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5)
 1170 FORMAT (/41H NUMBER OF NON ZERO WEIGHTED OBSERVATIONS, 27X,
     +   6H(NNZW), 1X, I5)
 1180 FORMAT (/32H NUMBER OF INDEPENDENT VARIABLES, 39X, 3H(M), 1X, I5)
 1200 FORMAT (/44H RESIDUAL SUM OF SQUARES FOR INPUT PARAMETER,
     +   7H VALUES, 24X, G11.4)
 1210 FORMAT (/48H RESIDUAL STANDARD DEVIATION FOR INPUT PARAMETER,
     +   7H VALUES, 14X, 5H(RSD), 1X, G11.4)
 1260 FORMAT (//50X, 13HSTEP SIZE FOR/
     +   50X, 13HAPPROXIMATING/
     +   7X, 24HPARAMETER STARTING VALUE, 6X, 5HSCALE, 10X,
     +   10HDERIVATIVE/
     +   1X, 5HINDEX, 2X, 5HFIXED, 6X, 5H(PAR), 12X, 7H(SCALE), 11X,
     +   5H(STP)/)
 1270 FORMAT (//6X, 25HPARAMETER STARTING VALUES, 5X, 5HSCALE/
     +   1X, 5HINDEX, 2X, 5HFIXED, 6X, 5H(PAR), 11X, 7H(SCALE)/)
 1310 FORMAT (1X, I3, 5X, ' NO', G17.8, 7X, 7HDEFAULT, 3X, G17.8)
 1410 FORMAT (1X, I3, 5X, ' NO', 3G17.8)
 1510 FORMAT (1X, I3, 5X, 'YES', G17.8, 9X, '---', 14X, '---')
 1610 FORMAT (1X, I3, 5X, 'YES', G17.8, 9X, '---')
      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
      REAL
     +   PARE(NPAR),RWORK(IRWORK)
      INTEGER
     +   IFIXD(NPAR),IWORK(IIWORK)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL NLHDR
C
C  LOCAL SCALARS
      REAL
     +   RSD,RSS,RSSC,RSSPC
      INTEGER
     +   DST0,F,F0,FDIF,ICASE,IPRT,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 IPRINT,LSTVCF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD,REAL,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 REAL 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     REAL 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     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL RSSC
C        THE CHANGE IN THE RESIDUAL SUM OF SQUARES CAUSED BY THIS
C        ITERATION.
C     REAL RSSPC
C        THE PREDICTED CHANGE IN THE RESIDUAL SUM OF SQUARES AT THIS
C        ITERATION.
C     REAL RWORK(IRWORK)
C        THE REAL 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
      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
      CALL IPRINT(IPRT)
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 (IPRT,1000) IWORK(NITER)
C
C     COMPUTE STATISTICS TO BE PRINTED
C
      RSS = 2.0E0*RWORK(F)
      RSD = SQRT(RSS)
      IF (NNZW-NPARE.GE.1) RSD = RSD/SQRT(REAL(NNZW-NPARE))
C
      RSSC = 0.0E0
      IF (RWORK(F0).GT.0.0E0) RSSC = RWORK(FDIF)/RWORK(F0)
C
      RSSPC = 0.0E0
      IF (RWORK(F0).GT.0.0E0) 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.0E0*RWORK(PREDUC)) GO TO 10
      IF (RWORK(DST0).LT.0.0E0) GO TO 10
      IF (RWORK(NREDUC).GE.0.0E0) ISCHKD(1) = LETTRY
      IF (RWORK(STPPAR).EQ.0.0E0) ISCHKD(2) = LETTRY
   10 CONTINUE
C
      WRITE (IPRT,1010) IWORK(NFCALL), RSD, RSS, RSSC, RSSPC,
     +   ISCHKD(1), RWORK(RELDX), ISCHKD(2)
      IF (NPARE.LT.NPAR) WRITE (IPRT,1020)
      IF (NPARE.GE.NPAR) WRITE (IPRT,1150)
      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 WRITE (IPRT,1030)
      RETURN
C
C     ***** RESIDUAL SUM OF SQUARES CONVERGENCE *****
C
   30 WRITE (IPRT,1040)
      RETURN
C
C     ***** PARAMETER AND RESIDUAL SUM OF SQUARES CONVERGENCE ****
C
   40 WRITE (IPRT,1050)
      RETURN
C
C     ***** RESIDUAL SUM OF SQUARES IS EXACTLY ZERO *****
C
   50 WRITE (IPRT,1060)
      RETURN
C
C     ***** SINGULAR CONVERGENCE *****
C
   60 WRITE (IPRT,1070)
      RETURN
C
C     ***** FALSE CONVERGENCE *****
C
   70 WRITE (IPRT,1080)
      RETURN
C
C     ***** LIMIT ON NUM. OF CALLS TO THE MODEL SUBROUTINE REACHED *****
C
   80 WRITE (IPRT,1090)
      RETURN
C
C     ***** ITERATION LIMIT REACHED *****
C
   90 WRITE (IPRT,1100)
      RETURN
C
C     ***** STOPX *****
C
  100 WRITE (IPRT,1110)
      RETURN
C
C     ***** INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS *****
C
  110 WRITE (IPRT,1120)
      RETURN
C
C     ***** BAD PARAMETERS TO ASSESS *****
C
  120 WRITE (IPRT,1130)
      RETURN
C
C     ***** J COULD NOT BE COMPUTED *****
C
  130 WRITE (IPRT,1140)
      RETURN
C
  140 RETURN
C
C      FORMAT STATEMENTS
C
 1000 FORMAT (//17H ITERATION NUMBER, I5/1X, 22('-'))
 1010 FORMAT (5X, 5HMODEL, 53X, 10HFORECASTED/5X, 5HCALLS, 9X, 3HRSD,
     +   13X, 3HRSS, 8X, 12HREL CHNG RSS, 4X, 12HREL CHNG RSS, 4X,
     +   12HREL CHNG PAR/62X, 5HVALUE, 3X, 4HCHKD, 4X, 5HVALUE, 3X,
     +   4HCHKD/3X, I7, 3(2X, G14.4), 2(G12.4, 3X, A1))
 1020 FORMAT (/5X, 25H CURRENT PARAMETER VALUES, 19H (ONLY UNFIXED PARA,
     +   18HMETERS ARE LISTED))
 1030 FORMAT (/34H ***** PARAMETER CONVERGENCE *****)
 1040 FORMAT (/48H ***** RESIDUAL SUM OF SQUARES CONVERGENCE *****)
 1050 FORMAT (/44H ***** PARAMETER AND RESIDUAL SUM OF SQUARES,
     +   18H CONVERGENCE *****)
 1060 FORMAT (/50H ***** THE RESIDUAL SUM OF SQUARES IS EXACTLY ZERO,
     +   6H *****)
 1070 FORMAT (/33H ***** SINGULAR CONVERGENCE *****)
 1080 FORMAT (/30H ***** FALSE CONVERGENCE *****)
 1090 FORMAT (/44H ***** LIMIT ON NUMBER OF CALLS TO THE MODEL,
     +   25H SUBROUTINE REACHED *****)
 1100 FORMAT (/36H ***** ITERATION LIMIT REACHED *****)
 1110 FORMAT (/18H ***** STOPX *****)
 1120 FORMAT (/53H ***** INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS ****,
     +   1H*)
 1130 FORMAT (/37H ***** BAD PARAMETERS TO ASSESS *****)
 1140 FORMAT (/52H ***** DERIVATIVE MATRIX COULD NOT BE COMPUTED *****)
 1150 FORMAT (/5X, 25H CURRENT PARAMETER VALUES)
      END
*NLMN
      SUBROUTINE NLMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, MDL,
     +   NLDRV, APRXDV, DRV, IFIXD, PAR, PARE, NPAR, RES, PAGE, WIDE,
     +   HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE, DELTA,
     +   IVAPRX, IPTOUT, NDIGIT, RSD, PV, SDPVI, SDRESI, VCVL, LVCVL, D,
     +   IWORK, IIWORK, RWORK, IRWORK, NLHDR, NPARE)
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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IIWORK,IRWORK,IVAPRX,IXM,LSCALE,LSTP,LVCVL,LWT,M,MIT,N,
     +   NDIGIT,NNZW,NPAR,NPARE,SDPVI,SDRESI,VCVL
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   D(N,NPAR),PAR(NPAR),PARE(NPAR),PV(N),RES(N),RWORK(IRWORK),
     +   SCALE(LSCALE),STP(LSTP),WT(LWT),XM(IXM,M),Y(N)
      INTEGER
     +   IFIXD(NPAR),IPTOUT(NDIGIT),IWORK(IIWORK)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL,NLDRV,NLHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   WTSQRT
      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 NL2ITR,NLERR,NLFIN,NLINIT,NLISM,NLITRP,NLSUPK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
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     REAL D(N,NPAR)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
C     REAL 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 REAL 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 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 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 NLDRV
C        THE NAME OF THE ROUTINE WHICH CALCULATED 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 OPTIMIZED.
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     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL 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     REAL PV(N)
C        THE PREDICTED VALUES.
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     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     INTEGER RSAVE
C        THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK
C        THE ARRAY RSAVE.
C     REAL 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     REAL RWORK(IRWORK)
C        THE REAL 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     REAL 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     REAL 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     REAL 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     REAL 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL WTSQRT
C        THE SQUARE ROOT OF THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
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 (N, 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
C     COMPUTE RESIDUALS
C
   10 CALL MDL(PAR, NPAR, XM, N, M, IXM, PV)
C
      DO 20 I=1,N
         WTSQRT = 1.0E0
         IF (WEIGHT) WTSQRT = SQRT(WT(I))
         RES(I) = WTSQRT*(Y(I)-PV(I))
   20 CONTINUE
C
C     PRINT INITIAL SUMMARY
C
      IF (.NOT.PRTSMY) GO TO 30
      CALL NLISM(NLHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW, WEIGHT,
     +   IFIXD, PAR, SCALE, IWORK, IIWORK, RWORK, IRWORK, RES, 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 MDL(PAR, NPAR, XM, N, M, IXM, PV)
C
      CALL NLDRV (MDL, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M, IXM,
     +   PV, 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, N, N, NPARE, RES, 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
C     EQUIVALENCE LOCATIONS WITHIN RWORK.
C
      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
      CALL NLFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD, PAR,
     +   NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RWORK(RSSHLF),
     +   RSD, PV, RWORK(SDPVI), RWORK(SDRESI), RWORK(RDI), RWORK(VCVL),
     +   LVCVL, D, NLHDR, IVCVPT, ISKULL)
C
      RETURN
C
      END
*NLOUT
      SUBROUTINE NLOUT(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD,
     +   PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND, RSS,
     +   RSD, YSS, EXACT, PV, SDPV, SDRES, VCVL, LVCVL, IVCVPT, ISKULL,
     +   NLHDR, WIDE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE FINAL SUMMARY OUTPUT FROM THE
C     NONLINEAR LEAST SQUARES SUBOUTINES.
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
      REAL
     +   COND,RSD,RSS,YSS
      INTEGER
     +   IDF,IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE
      LOGICAL
     +   EXACT,PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCVL(LVCVL),WT(LWT),
     +   XM(IXM,M),Y(N)
      INTEGER
     +   IFIXD(NPAR),IPTOUT(NDIGIT),ISKULL(10)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL NLHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   FPLM,PLL,PUL,RATIO,SDPAR,T
      INTEGER
     +   I,IPK,IPK2,IPRT,ISUBHD
C
C  EXTERNAL FUNCTIONS
      REAL
     +   PPFT,R1MACH
      EXTERNAL PPFT,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FITPT1,FITPT2,IPRINT,NLSKL,VCVOTF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL COND
C        THE CONDITION NUMBER OF D.
C     LOGICAL EXACT
C        AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT
C        WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE).
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IDF
C        THE DEGREES OF FREEDOM IN THE FIT.
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 IPK
C        AN INDEX.
C     INTEGER IPK2
C        THE INDEX OF THE "DIAGONAL" ELEMENT OF THE VCV
C        MATRIX.
C     INTEGER IPRT
C        THE LOGICAL UNIT 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 ISUBHD
C        AN INTEGER 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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LVCVL
C        THE LENGTH OF THE VECTOR CONTANING
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 N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
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     REAL PAR(NPAR)
C        THE PARAMETER ESTIMATES.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER OR NOT THE OUTPUT
C        IS TO BEGIN ON A NEW PAGE.
C     REAL PLL, PUL
C        THE LOWER AND UPPER CONFIDENCE LIMITS FOR A GIVEN PARAMETER.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RATIO
C        THE RATIO OF A GIVEN PARAMETER VALUE TO ITS STANDARD ERROR.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
C     REAL RSS
C        THE RESIDUAL SUM OF SQUARES.
C     REAL SDPAR
C        THE STANDARD DEVIATION OF A GIVEN PARAMETER VALUE.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL T
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     REAL VCVL(LVCVL)
C        THE LOWER HALF OF THE 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     REAL WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C     REAL YSS
C        THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y.
C
C
      FPLM = R1MACH(2)
C
      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, NLHDR)
C
C     PRINT PRIMARY REPORT
C
      IF ((IERR.EQ.0) .AND. (IPTOUT(3).EQ.0)) GO TO 10
      ISUBHD = 0
      CALL NLHDR(PAGE, WIDE, ISUBHD)
      CALL FITPT1(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, NNZW,
     +   WEIGHT, MAX(1, IPTOUT(3)))
C
C     PRINT STANDARDIZED RESIDUAL PLOTS
C
   10 IF (IPTOUT(4).EQ.0) GO TO 20
      ISUBHD = 0
      CALL NLHDR(PAGE, WIDE, ISUBHD)
C
      CALL FITPT2 (SDRES, PV, WT, N, NNZW, WEIGHT, RES, RSS)
C
C     PRINT THE COVARIANCE AND CORRELATION MATRIX
C
   20 IF ((IERR.EQ.0) .AND. (IPTOUT(5).EQ.0)) RETURN
      ISUBHD = 0
      CALL NLHDR(PAGE, WIDE, ISUBHD)
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 WRITE (IPRT,1000)
      WRITE (IPRT,1010)
C
      T = PPFT(0.975E0,IDF)
      IPK = 0
      DO 50 I=1,NPAR
C
         IF (IFIXD(I).EQ.0) GO TO 40
C
         WRITE (IPRT,1030) I, PAR(I)
         GO TO 50
C
   40    IPK = IPK + 1
         IPK2 = IPK*(IPK-1)/2 + IPK
         RATIO = FPLM
         SDPAR = SQRT(VCVL(IPK2))
         IF (SDPAR.GT.0.0E0) RATIO = PAR(I)/SDPAR
         PLL = PAR(I) - T*SDPAR
         PUL = PAR(I) + T*SDPAR
         WRITE (IPRT,1020) I, PAR(I), SDPAR, RATIO, PLL, PUL
   50 CONTINUE
      WRITE (IPRT,1040) RSS, RSD, NNZW, NPARE, IDF
      WRITE (IPRT,1050) COND
C
      IF (RSS.GT.YSS) WRITE (IPRT,1060)
C
      RETURN
C
C     PRINT OUT ERROR HEADING
C
   60 CALL NLSKL(ISKULL, PAGE, WIDE, NLHDR)
C
      IF (IERR.LE.2) RETURN
C
C     PRINT SECONDARY REPORT
C
   70 CONTINUE
      ISUBHD = 0
      CALL NLHDR(PAGE, WIDE, ISUBHD)
      IF (IERR.NE.0) WRITE (IPRT,1080)
      WRITE (IPRT,1000)
      WRITE (IPRT,1100)
      DO 80 I=1,NPAR
         IF (IFIXD(I).EQ.0) WRITE (IPRT,1110) I, PAR(I)
         IF (IFIXD(I).NE.0) WRITE (IPRT,1120) I, PAR(I)
   80 CONTINUE
      WRITE (IPRT,1040) RSS, RSD, NNZW, NPARE, IDF
      IF (IERR.NE.3) WRITE (IPRT,1050) COND
C
      IF ((IERR.EQ.0) .AND. (.NOT.EXACT) .AND. (IDF.LE.0)) WRITE
     +   (IPRT,1070)
      IF ((IERR.EQ.0) .AND. EXACT) WRITE (IPRT,1090)
C
      IF (IERR.NE.0) GO TO 100
C
      DO 90 I=1,N
         SDRES(I) = 0.0E0
         SDPV(I) = 0.0E0
   90 CONTINUE
C
      RETURN
C
  100 CONTINUE
C
      DO 110 I=1,N
         SDRES(I) = FPLM
         SDPV(I) = FPLM
  110 CONTINUE
C
C     PRINT OUT ERROR EXIT STATISTICS
C
      CALL FITPT1(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, NNZW,
     +   WEIGHT, MAX(IPTOUT(3),1))
C
C
C     WIPE OUT SDRES VECTOR
C
      DO 120 I=1,N
         SDRES(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
 1000 FORMAT (///33H ESTIMATES FROM LEAST SQUARES FIT/1X, 33('-'))
 1010 FORMAT (//69X, 11HAPPROXIMATE/61X, 28H95 PERCENT CONFIDENCE LIMITS
     +   /1X, 5HINDEX, 2X, 5HFIXED, 3X, 9HPARAMETER, 8X, 9HSD OF PAR,
     +   7X, 5HRATIO, 12X, 5HLOWER, 12X, 5HUPPER/)
 1020 FORMAT (1X, I3, 5X, 3H NO, 2G17.8, 2X, G10.4, 2G17.8)
 1030 FORMAT (1X, I3, 5X, 3HYES, G17.8, 10X, 3H---, 8X, 3H---, 15X,
     +   3H---, 14X, 3H---)
 1040 FORMAT (//31H RESIDUAL SUM OF SQUARES       , 8X, G15.7//6H RESID,
     +   25HUAL STANDARD DEVIATION   , 8X, G15.7/19H BASED ON DEGREES O,
     +   9HF FREEDOM, 5X, I4, 3H - , I3, 3H = , I4)
 1050 FORMAT (/29H APPROXIMATE CONDITION NUMBER, 10X, G15.7)
 1060 FORMAT (52H THE RESIDUAL SUM OF SQUARES AFTER THE LEAST SQUARES,
     +   20H FIT IS GREATER THAN/35H THE SUM OF SQUARES ABOUT THE MEAN ,
     +   19HY OBSERVATION.  THE, 14H MODEL IS LESS/17H REPRESENTATIVE O,
     +   39HF THE DATA THAN A SIMPLE AVERAGE.  DATA, 15H AND MODEL SHOU,
     +   2HLD/48H BE CHECKED TO BE SURE THAT THEY ARE COMPATABLE.)
 1070 FORMAT (/49H THE DEGREES OF FREEDOM FOR THIS PROBLEM IS ZERO.,
     +   54H  STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.)
 1080 FORMAT (//40H THE FOLLOWING SUMMARY SHOULD BE USED TO, 8H ANALYZE,
     +   30H THE ABOVE MENTIONED PROBLEMS.)
 1090 FORMAT (/50H THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS,
     +   35H EXACT TO WITHIN MACHINE PRECISION./20H STATISTICAL ANALYSI,
     +   33HS OF THE RESULTS IS NOT POSSIBLE.)
 1100 FORMAT (//1X, 5HINDEX, 2X, 5HFIXED, 3X, 9HPARAMETER)
 1110 FORMAT (1X, I3, 5X, 3H NO, G17.8)
 1120 FORMAT (1X, I3, 5X, 3HYES, G17.8)
      END
*NLSC
      SUBROUTINE NLSC(Y, XM, N, M, IXM, MDL, PAR, NPAR, RES, LDSTAK,
     +   IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES
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  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),SCALE(*),STP(*),XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,NNZW,
     +   NPARE
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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 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 IFIXED(NPAR)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL STP(NPAR)
C        THE STEP SIZE ARRAY.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(1)
C        THE DUMMY ARRAY FOR THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','C',' ',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .FALSE.
      SAVE = .FALSE.
C
      WT(1) = 1.0E0
      LIFIXD = NPAR
      LPV = 1
      LSCALE = NPAR
      LSTP = NPAR
      LSDPV = 1
      LSDRES = 1
      LWT = 1
      IVCV = 1
C
      CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSC (Y, XM, N, M, IXM, NLSMDL,'/
     +   '      +           PAR, NPAR, RES, LDSTAK,'/
     +   '      +           IFIXED, STP, MIT, STOPSS, STOPP,'/
     +   '      +           SCALE, DELTA, IVAPRX, NPRT)')
      END
*NLSDC
      SUBROUTINE NLSDC(Y, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, IDRVCK, MIT, STOPSS, STOPP, SCALE, DELTA,
     +   IVAPRX, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING ANALYTIC DERIVATIVES WITH USER
C     SUPPLIED CONTROL PARAMETERS.
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
      REAL
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),SCALE(*),XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT,NNZW,NPARE
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTA
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     INTEGER IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE
C        CHECKED OR NOT.
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 IFIXED(NPAR)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL VCV(1,1)
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE COVARIANCE MATRIX.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(1)
C        THE DUMMY ARRAY FOR THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','D','C',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .FALSE.
      SAVE = .FALSE.
C
      WT(1) = 1.0E0
      LIFIXD = NPAR
      LPV = 1
      LSCALE = NPAR
      LSDPV = 1
      LSDRES = 1
      LWT = 1
      IVCV = 1
C
      CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSDC (Y, XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +            PAR, NPAR, RES, LDSTAK,'/
     +   '      +            IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/
     +   '      +            SCALE, DELTA, IVAPRX, NPRT)')
      END
*NLSD
      SUBROUTINE NLSD(Y, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING ANALYTIC DERIVATIVES (SHORT CALL).
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
     +   IXM,LDSTAK,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),XM(*),Y(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,
     +   LWT,MIT,NNZW,NPARE,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SCALE(1),SDPV(1),SDRES(1),VCV(1,1),WT(1)
      INTEGER
     +   IFIXED(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTA
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     INTEGER IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE
C        CHECKED OR NOT.
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 IFIXED(1)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(1)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(1)
C        THE DUMMY ARRAY FOR THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','D',' ',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .FALSE.
      SAVE = .FALSE.
C
      WT(1) = 1.0E0
      IDRVCK = 1
      MIT = -1
      STOPSS = -1.0E0
      STOPP = -1.0E0
      SCALE(1) = -1.0E0
      DELTA = -1.0E0
      NPRT = -1
      IFIXED(1) = -1
      IVAPRX = 0
      LIFIXD = 1
      LPV = 1
      LSCALE = 1
      LSDPV = 1
      LSDRES = 1
      LWT = 1
      IVCV = 1
C
      CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSD (Y, XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +           PAR, NPAR, RES, LDSTAK)')
      END
*NLSDS
      SUBROUTINE NLSDS(Y, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, IDRVCK, 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 NONLINEAR LEAST
C     SQUARES REGRESSION USING ANALYTIC DERIVATIVES WITH USER
C     SUPPLIED CONTROL PARAMETERS, AND WITH COMPUTED VALUES RETURNED
C     TO THE USER.
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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NPAR,NPARE,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),VCV(*),XM(*),
     +   Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT,NNZW
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTA
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     INTEGER IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE
C        CHECKED OR NOT.
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 IFIXED(NPAR)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL VCV(IVCV,NPAR)
C        THE COVARIANCE MATRIX.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(1)
C        THE DUMMY ARRAY FOR THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','D','S',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .FALSE.
      SAVE = .TRUE.
C
      WT(1) = 1.0E0
      LIFIXD = NPAR
      LPV = N
      LSCALE = NPAR
      LSDPV = N
      LSDRES = N
      LWT = 1
C
      CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSDS (Y, XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +            PAR, NPAR, RES, LDSTAK,'/
     +   '      +            IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/
     +   '      +            SCALE, DELTA, IVAPRX, NPRT,'/
     +   '      +            NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)')
      END
*NLS
      SUBROUTINE NLS(Y, XM, N, M, IXM, MDL, PAR, NPAR, RES, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES
C     (SHORT CALL).
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
     +   IXM,LDSTAK,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),XM(*),Y(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,
     +   MIT,NNZW,NPARE,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SCALE(1),SDPV(1),SDRES(1),STP(1),VCV(1,1),WT(1)
      INTEGER
     +   IFIXED(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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 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 IFIXED(1)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(1)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL STP(1)
C        THE STEP SIZE ARRAY.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(1)
C        THE DUMMY ARRAY FOR THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S',' ',' ',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .FALSE.
      SAVE = .FALSE.
C
      WT(1) = 1.0E0
      STP(1) = -1.0E0
      MIT = -1
      STOPSS = -1.0E0
      STOPP = -1.0E0
      SCALE(1) = -1.0E0
      DELTA = -1.0E0
      NPRT = -1
      IFIXED(1) = -1
      IVAPRX = 0
      LIFIXD = 1
      LPV = 1
      LSTP = 1
      LSCALE = 1
      LSDPV = 1
      LSDRES = 1
      LWT = 1
      IVCV = 1
C
      CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLS (Y, XM, N, M, IXM, NLSMDL,'/
     +   '      +          PAR, NPAR, RES, LDSTAK)')
      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
     +   IPRT,ISUBHD
C
C  EXTERNAL SUBROUTINES
      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
      CALL IPRINT(IPRT)
C
      ISUBHD = 0
      CALL NLHDR(PAGE, WIDE, ISUBHD)
C
      IF (WIDE) THEN
         WRITE (IPRT,1010)
         WRITE (IPRT,1020)
C        WRITE (IPRT,1030)
C        WRITE (IPRT,1040)
C        WRITE (IPRT,1050)
         WRITE (IPRT,1000)
      END IF
      WRITE (IPRT,1060)
C
C     VCV COMPUTATION NOT COMPLETED
C
      IF (ISKULL(7).NE.0) WRITE (IPRT,1120)
C
C     MAXIMUM NUMBER OF ITERATIONS REACHED BEFORE CONVERGENCE
C
      IF (ISKULL(6).NE.0) WRITE (IPRT,1100)
C
C     FALSE CONVERGENCE
C
      IF (ISKULL(5).NE.0) WRITE (IPRT,1090)
C
C     MEANINGLESS VCV MATRIX
C
      IF (ISKULL(4).NE.0) WRITE (IPRT,1080)
C
C     PROBLEM IS COMPUTATIONALLY SINGULAR
C
      IF (ISKULL(3).NE.0) WRITE (IPRT,1070)
C
C     INITIAL RESIDUAL SUM OF SQUARES COMPUTATION OVERFLOWED
C
      IF (ISKULL(2).NE.0) WRITE (IPRT,1110)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (///)
 1010 FORMAT (/48H  W      W     AA     RRRRRRR   N      N    IIII,
     +   19H    N      N    GGG/31H  W      W    A  A    R     RR ,
     +   38H NN     N     II     NN     N   G    G/12H  W      W  ,
     +   51H  A  A    R      R  N N    N     II     N N    N  G/
     +   59H  WW    WW   AA  AA   R     RR  N  N   N     II     N  N   ,
     +   4HN  G/47H   W    W    AAAAAA   RRRRRRR   N  NN  N     II,
     +   23H     N  NN  N  G  GGGGG)
 1020 FORMAT (49H   W WW W    A    A   R R       N   N  N     II  ,
     +   21H   N   N  N  G      G/29H   W WW W    A    A   R  R   ,
     +   41H   N    N N     II     N    N N  G      G/9H    W  W ,
     +   59H   AA    AA  R   R     N     NN     II     N     NN   G    ,
     +   2HGG/49H    W  W    A      A  R    R    N      N    IIII ,
     +   21H   N      N    GGGG G/)
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 (22H **  ERROR SUMMARY  **)
 1070 FORMAT (/50H THIS MODEL AND DATA ARE COMPUTATIONALLY SINGULAR.,
     +   29H CHECK YOUR INPUT FOR ERRORS.)
 1080 FORMAT (/43H AT LEAST ONE OF THE STANDARDIZED RESIDUALS, 6H COULD,
     +   47H NOT BE COMPUTED BECAUSE THE STANDARD DEVIATION, 8H OF THE ,
     +   18HRESIDUAL WAS ZERO./37H THE VALIDITY OF THE COVARIANCE MATRI,
     +   18HX IS QUESTIONABLE.)
 1090 FORMAT (/46H THE ITERATIONS DO NOT APPEAR TO BE CONVERGING,
     +   13H TO A MINIMUM, 41H (FALSE CONVERGENCE), INDICATING THAT THE,
     +   12H CONVERGENCE, 16H CRITERIA STOPSS/22H AND STOPP MAY BE TOO ,
     +   35HSMALL FOR THE ACCURACY OF THE MODEL, 17H AND DERIVATIVES,,
     +   52H THAT THERE IS AN ERROR IN THE DERIVATIVE MATRIX, OR/
     +   15H THAT THE MODEL, 39H IS DISCONTINUOUS NEAR THE CURRENT COEF,
     +   18HFICIENT ESTIMATES.)
 1100 FORMAT (/53H PROGRAM DID NOT CONVERGE IN THE NUMBER OF ITERATIONS,
     +   13H OR NUMBER OF, 32H MODEL SUBROUTINE CALLS ALLOWED.)
 1110 FORMAT (/50H THE RESIDUAL SUM OF SQUARES COULD NOT BE COMPUTED,
     +   19H USING THE STARTING, 26H MODEL COEFFICIENT VALUES.)
 1120 FORMAT (/44H THE VARIANCE-COVARIANCE MATRIX COULD NOT BE,
     +   26H COMPUTED AT THE SOLUTION.)
      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
      REAL
     +   PAR(NPAR),PPAR(NPPAR)
      INTEGER
     +   MASK(NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPPAR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PPAR(NPPAR)
C        OUTPUT PARAMETER.  THE PACKED VERSION OF PAR.  SEE INITIAL
C        DESCRIPTION.
C
C     COMMENCE BODY OF ROUTINE
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
*NLSS
      SUBROUTINE NLSS(Y, XM, N, M, IXM, MDL, 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 NONLINEAR LEAST
C     SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES
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  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NPAR,NPARE,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*),
     +   XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,NNZW
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   WT(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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 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 IFIXED(NPAR)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL STP(NPAR)
C        THE STEP SIZE ARRAY.
C     REAL 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     REAL WT(1)
C        THE DUMMY ARRAY FOR THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','S',' ',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .FALSE.
      SAVE = .TRUE.
C
      WT(1) = 1.0E0
      LIFIXD = NPAR
      LPV = N
      LSCALE = NPAR
      LSTP = NPAR
      LSDPV = N
      LSDRES = N
      LWT = 1
C
      CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSS (Y, XM, N, M, IXM, NLSMDL,'/
     +   '      +           PAR, NPAR, RES, LDSTAK,'/
     +   '      +           IFIXED, STP, MIT, STOPSS, STOPP,'/
     +   '      +           SCALE, DELTA, IVAPRX, NPRT,'/
     +   '      +           NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)')
      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
      REAL
     +   PAR(NPAR),PARE(NPAR)
      INTEGER
     +   MASK(NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,JPK
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PARE(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS BEING OPTIMIZED,
C        NOT INCLUDING THOSE WHOSE VALUES ARE FIXED.
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
*NLSWC
      SUBROUTINE NLSWC(Y, WT, XM, N, M, IXM, MDL, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX,
     +   NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES
C     AND WEIGHTS (CONTROL CALL).
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
      REAL
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),SCALE(*),STP(*),WT(*),XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,NNZW,
     +   NPARE
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SDPV(1),SDRES(1),VCV(1,1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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 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 IFIXED(NPAR)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL STP(NPAR)
C        THE STEP SIZE ARRAY.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(N)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','W','C',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .TRUE.
      SAVE = .FALSE.
C
      LIFIXD = NPAR
      LPV = 1
      LSCALE = NPAR
      LSTP = NPAR
      LSDPV = 1
      LSDRES = 1
      LWT = N
      IVCV = 1
C
      CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSWC (Y, WT, XM, N, M, IXM, NLSMDL,'/
     +   '      +            PAR, NPAR, RES, LDSTAK,'/
     +   '      +            IFIXED, STP, MIT, STOPSS, STOPP, SCALE,'/
     +   '      +            DELTA, IVAPRX, NPRT)')
      END
*NLSWDC
      SUBROUTINE NLSWDC(Y, WT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, IDRVCK, MIT, STOPSS, STOPP, SCALE, DELTA,
     +   IVAPRX, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING ANALYTIC DERIVATIVES, WEIGHTS, AND
C     USER SUPPLIED CONTROL PARAMETERS.
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
      REAL
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),SCALE(*),WT(*),XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   RSD
      INTEGER
     +   IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT,NNZW,NPARE
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SDPV(1),SDRES(1),VCV(1,1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTA
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     INTEGER IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE
C        TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 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 IFIXED(NPAR)
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 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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(N)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','W','D','C'/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .TRUE.
      SAVE = .FALSE.
C
      LIFIXD = NPAR
      LPV = 1
      LSCALE = NPAR
      LSDPV = 1
      LSDRES = 1
      LWT = N
      IVCV = 1
C
      CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSWDC (Y, WT, XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +             PAR, NPAR, RES, LDSTAK,'/
     +   '      +             IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/
     +   '      +             SCALE, DELTA, IVAPRX, NPRT)')
      END
*NLSWD
      SUBROUTINE NLSWD(Y, WT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING ANALYTIC DERIVATIVES AND WEIGHTS
C     (SHORT CALL).
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
     +   IXM,LDSTAK,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),WT(*),XM(*),Y(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,
     +   LWT,MIT,NNZW,NPARE,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SCALE(1),SDPV(1),SDRES(1),VCV(1,1)
      INTEGER
     +   IFIXED(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTA
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     INTEGER IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE
C        CHECKED OR NOT.
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 IFIXED(1)
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 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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDENDENT 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(1)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(N)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','W','D',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .TRUE.
      SAVE = .FALSE.
C
      IDRVCK = 1
      MIT = -1
      STOPSS = -1.0E0
      STOPP = -1.0E0
      SCALE(1) = -1.0E0
      DELTA = -1.0E0
      NPRT = -1
      IFIXED(1) = -1
      IVAPRX = 0
      LIFIXD = 1
      LPV = 1
      LSCALE = 1
      LSDPV = 1
      LSDRES = 1
      LWT = N
      IVCV = 1
C
      CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSWD (Y, WT, XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +            PAR, NPAR, RES, LDSTAK)')
      END
*NLSWDS
      SUBROUTINE NLSWDS (Y, WT, XM, N, M, IXM, MDL, DRV, PAR,
     +   NPAR, RES, LDSTAK, IFIXED, IDRVCK, MIT, STOPSS, STOPP, SCALE,
     +   DELTA, IVAPRX, NPRT, NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV,
     +   IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING ANALYTIC DERIVATIVES, WEIGHTS, AND
C     USER SUPPLIED CONTROL PARAMETERS, AND WITH COMPUTED VALUES
C     RETURNED TO THE USER.
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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NNZW,NPAR,NPARE,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),VCV(*),WT(*),
     +   XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTA
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     INTEGER IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE
C        TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 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 IFIXED(NPAR)
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 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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL STOPSS
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE
C        PREDICTED DECREASE IN THE RESIDUAL STANDARD DEVIATION (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     REAL 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     REAL WT(N)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'N',       'L',       'S',       'W',       'D',       'S'/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .TRUE.
      SAVE = .TRUE.
C
      LIFIXD = NPAR
      LPV = N
      LSCALE = NPAR
      LSDPV = N
      LSDRES = N
      LWT = N
C
      CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSWDS (Y, WT, XM, N, M, IXM, NLSMDL, NLSDRV,'/
     +   '      +             PAR, NPAR, RES, LDSTAK,'/
     +   '      +             IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/
     +   '      +             SCALE, DELTA, IVAPRX, NPRT,'/
     +   '      +             NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV,',
     +   ' IVCV)')
C
      END
*NLSW
      SUBROUTINE NLSW(Y, WT, XM, N, M, IXM, MDL, PAR, NPAR, RES, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES
C     AND WEIGHTS (SHORT CALL).
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
     +   IXM,LDSTAK,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),RES(*),WT(*),XM(*),Y(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,
     +   MIT,NNZW,NPARE,NPRT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      REAL
     +   PV(1),SCALE(1),SDPV(1),SDRES(1),STP(1),VCV(1,1)
      INTEGER
     +   IFIXED(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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 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 IFIXED(1)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(1)
C        A DUMMY ARRAY FOR
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(1)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(1)
C        A DUMMY ARRAY FOR
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL STP(1)
C        THE STEP SIZE ARRAY.
C     REAL VCV(1,1)
C        A DUMMY ARRAY FOR
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     REAL WT(N)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','W',' ',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .TRUE.
      SAVE = .FALSE.
C
      STP(1) = -1.0E0
      MIT = -1
      STOPSS = -1.0E0
      STOPP = -1.0E0
      SCALE(1) = -1.0E0
      DELTA = -1.0E0
      NPRT = -1
      IFIXED(1) = -1
      IVAPRX = 0
      LIFIXD = 1
      LPV = 1
      LSTP = 1
      LSCALE = 1
      LSDPV = 1
      LSDRES = 1
      LWT = N
      IVCV = 1
C
      CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSW (Y, WT, XM, N, M, IXM, NLSMDL,'/
     +   '      +           PAR, NPAR, RES, LDSTAK)')
      END
*NLSWS
      SUBROUTINE NLSWS(Y, WT, XM, N, M, IXM, MDL, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX,
     +   NPRT, NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES
C     AND WEIGHTS (LONG CALL).
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
      REAL
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NNZW,NPAR,NPARE,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*),
     +   WT(*),XM(*),Y(*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT
      LOGICAL
     +   SAVE,WEIGHT
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,NLCNTN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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 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 IFIXED(NPAR)
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 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
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
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 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.   N
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
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 NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
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     REAL SCALE(NPAR)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     REAL 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     REAL 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     REAL STP(NPAR)
C        THE STEP SIZE ARRAY.
C     REAL 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     REAL WT(N)
C        THE WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'N','L','S','W','S',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      WEIGHT = .TRUE.
      SAVE = .TRUE.
C
      LIFIXD = NPAR
      LPV = N
      LSCALE = NPAR
      LSTP = NPAR
      LSDPV = N
      LSDRES = N
      LWT = N
C
      CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NLSWS (Y, WT, XM, N, M, IXM, NLSMDL,'/
     +   '      +            PAR, NPAR, RES, LDSTAK,'/
     +   '      +            IFIXED, STP, MIT, STOPSS, STOPP,'/
     +   '      +            SCALE, DELTA, IVAPRX, NPRT,'/
     +   '      +            NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV,',
     +   ' IVCV)')
      END
*NLSX1
      SUBROUTINE NLSX1(MOD, PAR, NPAR, PV, SDPV, RES, SDRES, VCV, N,
     +   IVCV, NNZW, NPARE, RSD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     SET THE STARTING PARAMETER VALUES FOR NLSX
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
      REAL
     +   RSD
      INTEGER
     +   IVCV,MOD,N,NNZW,NPAR,NPARE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCV(IVCV,IVCV)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SETRV
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
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 IVCV
C        THE ACTUAL FIRST DIMENSION OF VCV.
C     INTEGER MOD
C        AN INDICATOR VALUE USED TO DESIGNATE THE MODEL FOR WHICH
C        THE PARAMETERS ARE TO BE SET.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C        TO BE PROVIDED.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS ESTIMATED BY THE ROUTINE.
C     INTEGER NNZW
C        THE NUMBER OF NONZERO WEIGHTS.
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PV(N)
C        THE PREDICTED VALUES.
C     REAL RES(N)
C        THE RESIDUALS.
C     REAL RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUES.
C     REAL SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL VCV(IVCV,IVCV)
C        THE VARIANCE COVARIANCE MATRIX.
C
C
C
      GO TO (10, 20, 30, 40, 50, 60), MOD
C
   10 PAR(1) = 0.725E0
      PAR(2) = 4.0E0
C
      GO TO 70
C
C
   20 PAR(1) = 1.0E0
      PAR(2) = 2.0E0
      PAR(3) = 3.0E0
C
      GO TO 70
C
C
   30 PAR(1) = 6.0E0
      PAR(2) = 5.0E0
      PAR(3) = 4.0E0
      PAR(4) = 3.0E0
      PAR(5) = 2.0E0
C
      GO TO 70

   40 CALL SETRV(PAR, NPAR, 0.0E0)
C
      GO TO 70
C
C
   50 CALL SETRV(PAR, NPAR, 0.5E0)
C
      GO TO 70
C
C
   60 PAR(1) = 100.0E0
      PAR(2) = 15.0E0
C
   70 CONTINUE
C
      DO 80 I=1,N
         RES(I) = -1.0E0
         PV(I) = -1.0E0
         SDPV(I) = -1.0E0
         SDRES(I) = -1.0E0
   80 CONTINUE
C
      DO 100 I=1,IVCV
         DO 90 J=1,IVCV
            VCV(I,J) = -1.0E0
   90    CONTINUE
  100 CONTINUE
C
      NNZW = -1
      NPARE = -1
      RSD = -1.0E0
C
      IERR = -1
C
      RETURN
C
      END
*NLSX2
      SUBROUTINE NLSX2(N, M, IXM, NPAR, IFIXED, STP, IDRVCK, MIT,
     +   STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE
C     ROUTINES IN THE NONLINEAR  LEAST SQUARES FAMILY.
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
      REAL
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IDRVCK,IVAPRX,IVCV,IXM,M,MIT,N,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   SCALE(10),STP(10)
      INTEGER
     +   IFIXED(10)
C
C  LOCAL SCALARS
      REAL
     +   SQMEPS
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RMDCON
      EXTERNAL RMDCON
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELTA
C        THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     INTEGER IDRVCK
C        THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE
C        TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 0).
C     INTEGER IFIXED(10)
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
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C        IFIXED(I).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED..
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(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 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(TRANSPOSE(JACOBIAN)*JACOBIAN)
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(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
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(TRANSPOSE(JACOBIAN)*JACOBIAN)
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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER MIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL SCALE(10)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C     REAL SQMEPS
C        THE SQUARE ROOT OF MACHINE PRECISION
C     REAL 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     REAL STOPSS
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE
C        PREDICTED DECREASE IN THE RESIDUAL STANDARD DEVIATION (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     REAL STP(10)
C        THE STEP SIZE ARRAY.
C
C
C     **SET UP FOR NORMAL STATEMENT**
C
      SQMEPS = SQRT(RMDCON(3))
C
      N = 6
      M = 1
      IXM = 10
      NPAR = 2
      MIT = 500
      DO 10 I=1,10
         STP(I) = SQMEPS
         SCALE(I) = 1.0E0
   10 CONTINUE
      IFIXED(1) = -1
      IDRVCK = 0
      STOPSS = 10.0E-5
      STOPP = 10.0E-5
      DELTA = 0.5E0
      NPRT = 11111
      IVAPRX = 3
      IVCV = 6
C
      RETURN
C
      END
*NRANDC
      SUBROUTINE NRANDC(Y, N, ISEED, YMEAN, SIGMA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE GENERATES N NORMALLY DISTRIBUTED PSEUDO-
C     RANDOM NUMBERS WITH MEAN YMEAN AND STANDARD DEVIATION SIGMA.  THE
C     NUMBERS GENERATED ARE DETERMINED BY ISEED.  THEY ARE RETURNED IN Y
C
C     ORIGIN - CONCEIVED BY DR. PETER TRYON TO FACILITATE USE OF
C          EXISTING RANDOM NUMBER GENERATOR
C
C     WRITTEN BY -
C          JOHN E. KOONTZ AND JANET R. DONALDSON
C          STATISTICAL ENGINEERING DIVISION
C          NATIONAL BUREAU OF STANDARDS,
C          BOULDER, COLORADO 80302
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SIGMA,YMEAN
      INTEGER
     +   ISEED,N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,ISEEDU
      LOGICAL
     +   ERR01,ERR02,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LN(8)*1,LONE(8)*1,LSIGMA(8)*1,LZERO(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RANDN
      EXTERNAL RANDN
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISRNG,ERSGE,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SOULD 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          THE INDEX OF THE COMPUTING LOOP
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THEIS 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 FOUND.
C     INTEGER IPRT
C        THE STANDARD OUTPUT FILE UNIT NUMBER
C     INTEGER ISEED
C        THE ISEED TO THE RANDOM NUMBER GENERATOR.
C        ISEED MUST LIE BETWEEN 0 AND 2**((MIN(32,I1MACH(8)+1))-1) -1,
C        INCLUSIVE.  IF ISEED IS NOT EQUAL TO 0, ISEED MUST BE ODD.
C     INTEGER ISEEDU
C        THE VALUE OF THE SEED ACTUALLY USED.
C     CHARACTER*1 LN(8), LONE(8), LSIGMA(8), LZERO(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE VARIABLES(S) CHECKED
C        FOR ERRORS
C     INTEGER N
C        THE LENGTH OF DATA SET GENERATED
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THIS SUBROUTINE
C     REAL SIGMA
C        THE STANDARD DEVIATION OF THE GENERATED VALUES.
C     REAL Y(N)
C        THE GENERATED RANDOM VALUES.
C     REAL YMEAN
C        THE MEAN OF THE GENERATED VALUES.
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'N',      'R',      'A',      'N',      'D',      'C'/
      DATA     LN(1),    LN(2),    LN(3),    LN(4),    LN(5),    LN(6),
     +         LN(7),    LN(8)/'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA   LONE(1),  LONE(2),  LONE(3),  LONE(4),  LONE(5),  LONE(6),
     +       LONE(7),  LONE(8)/'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/
      DATA LSIGMA(1),LSIGMA(2),LSIGMA(3),LSIGMA(4),LSIGMA(5),LSIGMA(6),
     +     LSIGMA(7),LSIGMA(8)/'S', 'I', 'G', 'M', 'A', ' ', ' ', ' '/
      DATA  LZERO(1), LZERO(2), LZERO(3), LZERO(4), LZERO(5), LZERO(6),
     +      LZERO(7), LZERO(8)/'Z', 'E', 'R', 'O', ' ', ' ', ' ', ' '/
C
      IERR = 0
C
      HEAD = .TRUE.
C
C     CHECK FOR INPUT ERRORS
C
      CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERR01, LONE)
      CALL ERSGE(NMSUB, LSIGMA, SIGMA, 0.0E0, 2, HEAD, ERR02, LZERO)
      CALL EISRNG(NMSUB, ISEED, ISEEDU, HEAD)
C
      IF (ERR01.OR.ERR02) THEN
C
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
        IERR = 1
C
      ELSE
C
C     GENERATE THE PSEUDO-RANDOM NUMBERS
C
        Y(1) = RANDN(ISEEDU)
        DO 20 I=1,N
           Y(I) = RANDN(0)*SIGMA + YMEAN
   20   CONTINUE
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NRANDC (Y, N, ISEED, YMEAN, SIGMA)')
      END
*NRAND
      SUBROUTINE NRAND (Y, N, ISEED)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE GENERATES N NORMALLY DISTRIBUTED PSEUDO-
C     RANDOM NUMBERS WITH ZERO MEAN AND UNIT STANDARD DEVIATION.  THE
C     NUMBERS GENERATED ARE DETERMINED BY ISEED.  THEY ARE RETURNED IN Y
C
C     ORIGIN - CONCEIVED BY DR. PETER TRYON TO FACILITATE USE OF
C          EXISTING RANDOM NUMBER GENERATOR
C
C     WRITTEN BY -
C          JOHN E. KOONTZ AND JANET R. DONALDSON
C          STATISTICAL ENGINEERING DIVISION
C          NATIONAL BUREAU OF STANDARDS
C          BOULDER, COLORADO 80302
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISEED,N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,ISEEDU
      LOGICAL
     +   ERR01,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LN(8)*1,LONE(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RANDN
      EXTERNAL RANDN
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISRNG,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SOULD 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          THE INDEX OF THE COMPUTING LOOP
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THEIS 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 FOUND.
C     INTEGER IPRT
C        THE STANDARD OUTPUT FILE UNIT NUMBER
C     INTEGER ISEED
C        THE ISEED TO THE RANDOM NUMBER GENERATOR.
C        ISEED MUST LIE BETWEEN 0 AND 2**((MIN(32,I1MACH(8)+1))-1) -1,
C        INCLUSIVE.  IF ISEED IS NOT EQUAL TO 0, ISEED MUST BE ODD.
C     INTEGER ISEEDU
C        THE VALUE OF THE SEED ACTUALLY USED.
C     CHARACTER*1 LN(8), LONE(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE VARIABLES(S) CHECKED
C        FOR ERRORS
C     INTEGER N
C        THE LENGTH OF DATA SET GENERATED
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THIS SUBROUTINE
C     REAL Y(N)
C        THE GENERATED RANDOM VALUES.
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'N',      'R',      'A',      'N',      'D',      ' '/
      DATA     LN(1),    LN(2),    LN(3),    LN(4),    LN(5),    LN(6),
     +         LN(7),    LN(8)/'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA   LONE(1),  LONE(2),  LONE(3),  LONE(4),  LONE(5),  LONE(6),
     +       LONE(7),  LONE(8)/'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/
C
      IERR = 0
C
      HEAD = .TRUE.
C
C     CHECK FOR INPUT ERRORS
C
      CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERR01, LONE)
      CALL EISRNG(NMSUB, ISEED, ISEEDU, HEAD)
C
      IF (ERR01) THEN
C
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
        IERR = 1
C
      ELSE
C
C     GENERATE THE PSEUDO-RANDOM NUMBERS
C
        Y(1) = RANDN(ISEEDU)
        DO 20 I=1,N
           Y(I) = RANDN(0)
   20   CONTINUE
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL NRAND(Y, N, ISEED)')
      END
*OANOVA
      SUBROUTINE OANOVA(YSUM, RED, NPAR, RVAR, NNZW, TEMP, IPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     COMPUTE AND PRINT ANALYSIS OF VARIANCE
C
C     WRITTEN BY DAVID HOGBEN, SEL, NBS.   10/09/69.
C
C     THIS ROUTINE WAS ADAPTED FROM THE OMNITAB ROUTINE OANOVA
C     BY - -
C
C     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
      REAL
     +   RVAR,YSUM
      INTEGER
     +   IPRT,NNZW,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   RED(NPAR),TEMP(NPAR)
C
C  LOCAL SCALARS
      REAL
     +   ASUM,CR,F1,F2,FPLM,PF1,PF2,RESMS,RESSS,SSU,V1F2,VR
      INTEGER
     +   I,K,NSUA
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFF,R1MACH
      EXTERNAL CDFF,R1MACH
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ASUM
C        *
C     REAL CR
C        *
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     REAL F1
C        *
C     REAL F2
C        *
C     INTEGER I
C        AN INDEX.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER K
C        *
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NSUA
C        *
C     REAL PF1
C        *
C     REAL PF2
C        *
C     REAL RED(NPAR)
C        THE REDUCTION TO THE SUM OF SQUARES DUE TO EACH PARAMETER.
C     REAL RESMS
C        *
C     REAL RESSS
C        *
C     REAL RVAR
C        THE RESIDUAL VARIANCE.
C     REAL SSU
C        *
C     REAL TEMP(NPAR)
C        A WORK VECTOR.
C     REAL VR
C        *
C     REAL V1F2
C        *
C     REAL YSUM
C        THE SUM OF THE WEIGHTED DEPENDENT VARIABLES SQUARED.
C
C
      FPLM = R1MACH(2)
C
      RESMS = YSUM/NNZW
      NSUA = NNZW
      WRITE (IPRT,1000)
      ASUM = 0.0E0
      VR = NNZW-NPAR
      RESSS = VR*RVAR
      TEMP(NPAR) = RESSS
      IF (NPAR.EQ.1) GO TO 20
      DO 10 I=2,NPAR
         K = NPAR + 2 - I
         TEMP(K-1) = TEMP(K) + RED(K)
   10 CONTINUE
   20 V1F2 = NPAR+1
      SSU = NNZW
      DO 50 I=1,NPAR
         NSUA = NSUA - 1
         ASUM = ASUM + RED(I)
         SSU = SSU - 1.0E0
         CR = ASUM/I
         RESMS = 0.0E0
         IF (SSU.GT.0.0E0) RESMS = TEMP(I)/SSU
         V1F2 = V1F2 - 1.0E0
C
C     NEVER POOL
C
         IF (RVAR.GT.0.0E0) GO TO 30
         F1 = FPLM
         F2 = FPLM
         PF1 = 0.0E0
         PF2 = 0.0E0
         GO TO 40
   30    F1 = RED(I)/RVAR
         PF1 = 1.0E0 - CDFF(F1,1.0E0,VR)
C
C     TEST HIGHER SUB-HYPOTHESES
C
         F2 = (TEMP(I)+RED(I)-RESSS)/V1F2/RVAR
         PF2 = 1.0E0 - CDFF(F2,V1F2,VR)
   40    CONTINUE
         WRITE (IPRT,1010) I, RED(I), CR, I, RESMS, NSUA, F1, PF1, F2,
     +      PF2
   50 CONTINUE
      WRITE (IPRT,1020) RESSS, NSUA
      WRITE (IPRT,1030) YSUM, NNZW
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (////50X, 20HANALYSIS OF VARIANCE/24X, 16H-DEPENDENT ON OR,
     +   33HDER VARIABLES ARE ENTERED, UNLESS, 21H VECTORS ARE ORTHOGON,
     +   3HAL-//
     +   1X, 5H PAR , 4X, 14HSUM OF SQUARES, 63X,
     +   19H------ PAR=0 ------, 4X, 19H------ PARS=0 -----/
     +   1X, 5HINDEX, 4X, 14HRED DUE TO PAR, 7X, 10HCUM MS RED,
     +   6X, 9HDF(MSRED), 6X, 10HCUM RES MS, 6X, 7HDF(RMS), 5X,
     +   'F', 8X, 7HPROB(F), 7X, 'F', 8X, 7HPROB(F)/)
 1010 FORMAT (1X, I3, 6X, G16.9, 3X, G16.9, 1X, I6, 8X, G16.9, 1X, I5,
     +   4X, G12.6, F7.3, 4X, G12.6, F7.3)
 1020 FORMAT (/1X, 10HRESIDUAL  , 1X, G14.7, 20X, I6)
 1030 FORMAT (1X, 10HTOTAL     , 1X, G14.7, 20X, I6)
      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
      REAL
     +   PVT(N),RES(N),SDPVT(N),SDREST(N),Y(N)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,IPRT
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     REAL SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     REAL Y(N)
C        THE DEPENDENT VARIABLE.
C
      FPLM = R1MACH(2)
C
      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))
     +      WRITE (IPRT, 1060) I, Y(I), PVT(I), SDPVT(I), RES(I),
     +      SDREST(I)
         IF ((SDPVT(I).NE.FPLM) .AND. (SDREST(I).EQ.FPLM))
     +      WRITE (IPRT, 1050) I, Y(I), PVT(I), SDPVT(I), RES(I)
         IF ((SDPVT(I).EQ.FPLM) .AND. (SDREST(I).EQ.FPLM))
     +      WRITE (IPRT, 1080) I, Y(I), PVT(I), RES(I)
C
  140 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1050 FORMAT (1X, I4, 4E16.8, 4X, 4HNC *, 1X, E9.3)
 1060 FORMAT (1X, I4, 4E16.8, 1X, F7.2, 1X, E9.3)
 1080 FORMAT (1X, I4, 2E16.8, 8X, 4HNC *, 4X, E16.8, 4X, 4HNC *,
     +   1X, E9.3)
      END
*OBSSUM
      SUBROUTINE OBSSUM(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM,
     +   WEIGHT, K, IFIRST, ILAST, JCOL1, JCOLM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBOUTINE LISTS THE DATA SUMMARY FOR THE
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 29,  1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IFIRST,ILAST,IXM,JCOL1,JCOLM,K,M,N
      LOGICAL
     +   WEIGHT
C
C  ARRAY ARGUMENTS
      REAL
     +   PV(N),RES(N),SDPV(N),SDRES(N),WT(N),XM(IXM,M),Y(N)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I,IPRT,J
      CHARACTER
     +   STRING*20,FMT1*160,FMT2*160,FMT3*160
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      LOGICAL
     +   MVCHK
      EXTERNAL R1MACH,MVCHK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER*160 FMT1,FMT2,FMT3
C        THE FORMATS USED TO PRINT THE INFORMATION.
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IERR
C        THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS HAVE
C        BEEN DETECTED.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED
C        IF IERR .NE. 0, ERRORS HAVE BEEN DETECTED.
C     INTEGER IFIRST, ILAST
C        THE FIRST AND LAST INDICES TO BE LISTED.
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 JCOLM
C        THE LAST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED.
C     INTEGER JCOL1
C        THE FIRST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL RES(N)
C        THE RESIDUALS FROM THE FIT.
C     REAL SDPV(N)
C        THE STANDARD DEVIATION OF THE PREDICTED VALUE.
C     REAL SDRES(N)
C        THE STANDARD DEVIATIONS OF THE RESIDUALS.
C     CHARACTER*20 STRING
C        CHARACTER STRING USED TO BUILD THE FORMATS.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     REAL WT(N)
C        THE USER SUPPLIED WEIGHTS.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     REAL Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
      FPLM = R1MACH(2)
C
      CALL IPRINT(IPRT)
C
C     CONSTRUCT FORMAT
C
      IF (K.EQ.1) THEN
         STRING = '1X,I4,15X,G15.8,15X,'
      ELSE IF (K.EQ.2) THEN
         STRING = '1X,I4,7X,2G15.8,8X, '
      ELSE
         STRING = '1X,I4,3G15.8,       '
      END IF
      WRITE (FMT1,1020) STRING
      WRITE (FMT2,1030) STRING
      WRITE (FMT3,1040) STRING
C
      DO 140 I=IFIRST, ILAST
         IF (MVCHK(SDPV(I),FPLM)) THEN
            IF (WEIGHT) THEN
               WRITE (IPRT, FMT1) I, (XM(I,J),J=JCOL1,JCOLM),
     +                            Y(I), PV(I), RES(I), WT(I)
            ELSE
               WRITE (IPRT, FMT1) I, (XM(I,J),J=JCOL1,JCOLM),
     +                            Y(I), PV(I), RES(I)
            END IF
         ELSE
            IF (MVCHK(SDRES(I),FPLM)) THEN
               IF (WEIGHT) THEN
                  WRITE (IPRT, FMT2) I, (XM(I,J),J=JCOL1,JCOLM),
     +                               Y(I), PV(I), SDPV(I), RES(I), WT(I)
               ELSE
                  WRITE (IPRT, FMT2) I, (XM(I,J),J=JCOL1,JCOLM),
     +                               Y(I), PV(I), SDPV(I), RES(I)
               END IF
            ELSE
               IF (WEIGHT) THEN
                  WRITE (IPRT, FMT3) I, (XM(I,J),J=JCOL1,JCOLM),
     +                               Y(I), PV(I), SDPV(I), RES(I),
     +                               SDRES(I), WT(I)
               ELSE
                  WRITE (IPRT, FMT3) I, (XM(I,J),J=JCOL1,JCOLM),
     +                               Y(I), PV(I), SDPV(I), RES(I),
     +                               SDRES(I)
               END IF
            END IF
         END IF
  140 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1020 FORMAT ('(',A20,'2G16.8,8X,4HNC *,4X,G16.8,4X,4HNC *,1X,E9.3)')
 1030 FORMAT ('(',A20,'4G16.8,4X,4HNC *,1X,E9.3)')
 1040 FORMAT ('(',A20,'4G16.8,1X,F7.2,1X,E9.3)')
      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
      REAL
     +   V(33)
      INTEGER
     +   IV(21)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   VM(27),VX(27)
      CHARACTER
     +   CNGD(12)*1,DFLT(12)*1,VN(8,27)*1,WHICH(12)*1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RMDCON
      EXTERNAL RMDCON
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DFAULT,VCOPY
C
C     INTEGER IV(21), N, NN, P
C     REAL V(33)
C     DIMENSION IV(*), V(*)
C
C     EXTERNAL DFAULT, RMDCON, VCOPY
C     REAL 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     REAL 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
      DATA BIG/0.0E0/, NVDFLT/27/, TINY/1.0E0/, ZERO/0.0E0/
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.0E-3/, VM(2)/-0.99E0/, VM(3)/1.0E-3/, VM(4)/1.0E-2/,
     +     VM(5)/1.2E0/, VM(6)/1.0E-2/, VM(7)/1.2E0/, VM(8)/0.0E0/,
     +     VM(9)/0.0E0/, VM(10)/1.0E-3/, VM(11)/-1.0E0/, VM(15)/0.0E0/,
     +     VM(16)/0.0E0/, VM(19)/0.0E0/, VM(20)/-10.0E0/, VM(21)/0.0E0/,
     +     VM(23)/0.0E0/, VM(24)/1.0E10/, VM(27)/1.01E0/
      DATA VX(1)/0.9E0/, VX(2)/-1.0E-3/, VX(3)/1.0E1/, VX(4)/0.8E0/,
     +     VX(5)/1.0E2/, VX(6)/0.8E0/, VX(7)/1.0E2/, VX(8)/0.5E0/,
     +     VX(9)/0.5E0/, VX(10)/1.0E0/, VX(11)/1.0E0/, VX(14)/0.1E0/,
     +     VX(15)/1.0E0/, VX(16)/1.0E0/, VX(18)/1.0E0/, VX(22)/1.0E0/,
     +     VX(23)/1.0E0/, VX(25)/1.0E0/, VX(26)/1.0E0/, VX(27)/1.0E2/
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)
      PU = IV(PRUNIT)
      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) WRITE(PU,10) NN, N, P
 10           FORMAT(30H0///// BAD NN, N, OR P... NN =,I5,5H, N =,I5,
     +               5H, P =,I5)
              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) WRITE(PU,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN,
     +                               N, P
 40      FORMAT('0///// (NN,N,P) CHANGED FROM (',I5,',',I5,',',I3,
     +          ') TO (',I5,',',I5,',',I3,').')
         GO TO 999
C
 50   IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70
         IV(1) = 50
         IF (PU .NE. 0) WRITE(PU,60) IV1
 60      FORMAT('0/////  IV(1) =',I5,' SHOULD BE BETWEEN 0 AND 12.')
         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) WRITE(PU,100) IV(INITS)
 100     FORMAT(25H0/////  INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0,
     +          7H AND 2.)
 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) WRITE(PU,120) (VN(ICH, I), ICH=1, 8),
     +                                  (VN(ICH, I), ICH=1, 8),
     +                                  K, VK, VM(I), VX(I)
 120          FORMAT(8H0/////  ,8A1,5H.. V(,I2,3H) =,E11.3,7H SHOULD,
     +               ' BE BETWEEN',E11.3,4H AND,E11.3)
 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) WRITE(PU,150) K, I, V(I)
 150     FORMAT(12H0///// JTOL(,I3,6H) = V(,I3,3H) =,E11.3,
     +          20H SHOULD BE POSITIVE.)
         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(PU,190) IV(INITS)
 190     FORMAT(22H0NONDEFAULT VALUES..../20H INITS..... IV(25) =,I3)
 200  IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO  210
         IF (M .EQ. 0) WRITE(PU,215) (WHICH(ICH), ICH=1, 12)
         M = 1
         WRITE(PU,205) IV(DTYPE)
 205     FORMAT(20H DTYPE..... IV(16) =,I3)
 210  K = EPSLON
      L = PARSV1
      DO 240 I = 1, NVDFLT
         IF (V(K) .EQ. V(L)) GO TO 230
              IF (M .EQ. 0) WRITE(PU,215) (WHICH(ICH), ICH = 1, 12)
 215          FORMAT ('0',12A1,'ALUES....'/)
              M = 1
              WRITE (PU,220) (VN(ICH, I), ICH = 1, 8), K, V(K)
 220          FORMAT (1X, 8A1, 5H.. V(, I2, 3H) =, E15.7)
 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(PU,250) (V(I), I = JTOL1, JTOLP)
 250          FORMAT(24H0(INITIAL) JTOL ARRAY.../(1X,6E12.3))
 260     IF (V(D0INIT) .GT. ZERO) GO TO 999
              K = JTOL1 + P
              L = K + P - 1
              WRITE(PU,270) (V(I), I = K, L)
 270          FORMAT(22H0(INITIAL) D0 ARRAY.../1X,6E12.3)
C
 999  RETURN
C  ***  LAST CARD OF PARCHK FOLLOWS  ***
      END
*PARZEN
      SUBROUTINE PARZEN (LAG, W, LW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES AND STORES THE PARZEN LAG WINDOW
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   LAG,LW
C
C  ARRAY ARGUMENTS
      REAL
     +   W(LW)
C
C  LOCAL SCALARS
      INTEGER
     +   K,L
C
C  INTRINSIC FUNCTIONS
      INTRINSIC REAL
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER K
C        AN INDEX VARIABLE
C     INTEGER L
C        THE VALUE LAG/2.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     REAL W(LW)
C        THE VECTOR OF LAG WINDOWS.
C
      L = LAG/2
      W(1) = 1.0E0
      IF (L.LE.0) GO TO 15
      DO 10 K = 1, L
         W(K+1) = REAL(K) / REAL(LAG)
         W(K+1) = 1.0E0 + 6.0E0 * W(K+1) * W(K+1) * (W(K+1) - 1.0E0)
   10 CONTINUE
C
   15 CONTINUE
      L = L + 1
      DO 20 K = L, LAG
         W(K+1) = 1.0E0 - REAL(K) / REAL(LAG)
         W(K+1) = 2.0E0 * W(K+1) * W(K+1) * W(K+1)
   20 CONTINUE
C
      RETURN
      END
*PGMEST
      SUBROUTINE PGMEST (YFFT, NFFT, NF, CNST, PER, LPER)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE PERIODOGRAM ESTIMATES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   CNST
      INTEGER
     +   LPER,NF,NFFT
C
C  ARRAY ARGUMENTS
      REAL
     +   PER(LPER),YFFT(NFFT)
C
C  LOCAL SCALARS
      REAL
     +   FAC
      INTEGER
     +   I,ISN,NFFT2
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FFT,REALTR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL CNST
C        THE VARIANCE OF THE OBSERVED TIME SERIES TIMES THE NUMBER OF
C        OBSERVATIONS IN THE SERIES IF CALLED BY IPGM,
C        OR 1.0E0 IF CALLED BY PGM.
C     REAL FAC
C        A FACTOR USED FOR COMPUTATIONS OF THE INTEGRATED PERIODOGRAM.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER ISN
C        A CODE USED FOR THE FFT.
C     INTEGER LPER
C        THE LENGTH OF THE PERIODOGRAM ARRAY.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODOGRAM IS
C        COMPUTED.
C     INTEGER NFFT
C        THE EFFECTIVE NUMBER OF OBSERVATIONS FOR THE FFT TRANSFORM.
C     INTEGER NFFT2
C        THE EFFECTIVE NUMBER OF COMPLEX OBSERVATIONS FOR THE FFT
C        TRANSFORM.
C     REAL PER(LPER)
C        THE PERIODOGRAM.
C     REAL YFFT(NFFT)
C        THE CENTERED SERIES.
C
C     COMPUTE THE FOURIER COEFFICIENTS
C
      NFFT2 = (NFFT-2) / 2
      ISN = 2
C
      CALL FFT (YFFT(1), YFFT(2), NFFT2, NFFT2, NFFT2, ISN)
      CALL REALTR (YFFT(1), YFFT(2), NFFT2, ISN)
C
      FAC = 0.5E0 / (CNST * (NFFT-2))
C
      NF = NFFT2 + 1
C
      DO 10 I = 1, NF
         PER(I) = (YFFT(2*I-1)*YFFT(2*I-1) + YFFT(2*I)*YFFT(2*I)) * FAC
   10 CONTINUE
C
      RETURN
      END
*PGM
      SUBROUTINE PGM (YFFT, N, LYFFT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING
C     THE (RAW) PERIODOGRAM OF A SERIES (SHORT CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LDSTAK,LYFFT,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   FREQ,IEXTND,IPRT,LDSMIN,NALL0,NF,NFFT,NPRT,YAXIS
      LOGICAL
     +   ERR01,ERR02,ERR03,HEAD
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      CHARACTER
     +   LLDS(8)*1,LLYFFT(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,IPRINT,LDSCMP,PGMMN,SETESL,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      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     LOGICAL ERR01, ERR02, ERR03
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     INTEGER FREQ
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE
C        INTEGRATED SPECTRUM VALUES ARE STORED.
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IEXTND
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO
C        (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE
C        USED TO EXTEND THE SERIES.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     CHARACTER*1 LLDS(8), LLYFFT(8), LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE
C        TIME OF THIS CALL.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C        IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE,
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .EQ.  1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE.
C        IF NPRT .GE.  2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'P',       'G',       'M',       ' ',       ' ',       ' '/
      DATA
     + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5),
     +  LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA
     + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     +  LLYFFT(6), LLYFFT(7), LLYFFT(8)
     +  /'L','Y','F','F','T',' ',' ',' '/
      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, 17, 1, HEAD, ERR01, LN)
      IF (ERR01) GO TO 5
C
C     SET LENGTH OF EXTENDED SERIES
C
      CALL SETESL(N, 2, NFFT)
C
      CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR02, LLYFFT)
C
      CALL LDSCMP(2, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN)
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 2, HEAD, ERR03, LLDS)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 5
      GO TO 10
C
    5 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
C     SET THE SIZE OF THE WORK AREA
C
      CALL STKSET(LDSTAK, 4)
C
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET DEFAULT VALUES
C
      NPRT = -1
      IEXTND = 0
C
C     SUBDIVIDE THE WORK ARRAY
C
      YAXIS = STKGET(NFFT/2, 3)
      FREQ = STKGET(NFFT/2, 3)
      CALL PGMMN (YFFT, N, NFFT, IEXTND, NF, YFFT, LYFFT, RSTAK(YAXIS),
     +   RSTAK(FREQ), NFFT/2, NPRT, NMSUB)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL PGM (YFFT, N, LYFFT, LDSTAK)')
      END
*PGMMN
      SUBROUTINE PGMMN (YFFT, N, NFFT, IEXTND, NF, PER, LPER, YAXIS,
     +   FREQ, LFREQ, NPRT, NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS THE MAIN ROUTINE FOR COMPUTING THE RAW PERIODOGRAM.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   IEXTND,LFREQ,LPER,N,NF,NFFT,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(LFREQ),PER(LPER),YAXIS(LFREQ),YFFT(NFFT)
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      REAL
     +   YEXTND
      INTEGER
     +   I,N1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,PGMEST,PGORD,PGOUT,SETFRQ
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FREQ(LFREQ)
C        THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE
C        INTEGRATED SPECTRUM VALUES ARE STORED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IEXTND
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO
C        (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE
C        USED TO EXTEND THE SERIES.
C     INTEGER LFREQ
C        THE LENGTH OF THE ARRAY FREQ.
C     INTEGER LPER
C        THE LENGTH OF THE ARRAY PER.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C        IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE,
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .EQ.  1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE.
C        IF NPRT .GE.  2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C     REAL PER(LPER)
C        THE ARRAY IN WHICH THE PERIODOGRAM IS STORED.
C     REAL YAXIS(LFREQ)
C        THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED.
C     REAL YEXTND
C        THE VALUE USED TO EXTEND THE SERIES.
C     REAL YFFT(NFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C
      YEXTND = 0.0E0
      IF (IEXTND .NE. 0) CALL AMEAN (YFFT, N, YEXTND)
C
C     EXTEND THE PERIODOGRAM ARRAY BY ITS MEAN  OR ZERO TO THE
C     EXTENDED LENGTH NFFT.
C
      N1 = N + 1
C
      DO 40 I = N1, NFFT
         YFFT(I) = YEXTND
   40 CONTINUE
C
C     COMPUTE THE PERIODOGRAM.
C
      CALL PGMEST (YFFT, NFFT, NF, 1.0E0, PER, LPER)
C
C     SET FREQUENCIES FOR PERIODOGRAM VALUES
C
      CALL SETFRQ (FREQ, NF, 1, 0.0E0, 0.5E0, 1.0E0)
C
      IF (NPRT .EQ. 0) RETURN
C
C     SET Y CO-ORDINATES FOR PERIODOGRAM PLOT.
C
      CALL PGORD (PER, NF, YAXIS, NPRT)
C
C     PLOT PERIODOGRAM IF OUTPUT NOT SUPPRESSED
C
      CALL PGOUT (YAXIS, FREQ, NF, NPRT, NMSUB)
C
      RETURN
C
      END
*PGMS
      SUBROUTINE PGMS (YFFT, N, NFFT, LYFFT, IEXTND, NF, PER, LPER,
     +   FREQ, LFREQ, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING
C     THE (RAW) PERIODOGRAM OF A SERIES (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IEXTND,LFREQ,LPER,LYFFT,N,NF,NFFT,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),PER(*),YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,NFFT2
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LLFREQ(8)*1,LLPER(8)*1,LLYFFT(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ENFFT,IPRINT,PGMMN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
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     REAL FREQ(LFREQ)
C        THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE
C        INTEGRATED SPECTRUM VALUES ARE STORED.
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IEXTND
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO
C        (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE
C        USED TO EXTEND THE SERIES.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER LFREQ
C        THE LENGTH OF THE ARRAY FREQ.
C     CHARACTER*1 LLFREQ(8), LLPER(8), LLYFFT(8), LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER LPER
C        THE LENGTH OF THE ARRAY PER.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED.
C     INTEGER NFFT2
C        THE EFFECTIVE SERIES LENGTH ACTUALLY USED.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C        IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE,
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .EQ.  1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE.
C        IF NPRT .GE.  2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     REAL PER(LPER)
C        THE ARRAY IN WHICH THE PERIODOGRAM IS STORED.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'P',       'G',       'M',       'S',       ' ',       ' '/
      DATA
     + LLFREQ(1), LLFREQ(2), LLFREQ(3), LLFREQ(4), LLFREQ(5),
     +  LLFREQ(6), LLFREQ(7), LLFREQ(8)
     +  /'L','F','R','E','Q',' ',' ',' '/
      DATA
     + LLPER(1), LLPER(2), LLPER(3), LLPER(4), LLPER(5),
     +  LLPER(6), LLPER(7), LLPER(8) /'L','P','E','R',' ',' ',' ',' '/
      DATA
     + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     +  LLYFFT(6), LLYFFT(7), LLYFFT(8)
     +  /'L','Y','F','F','T',' ',' ',' '/
      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, 17, 1, HEAD, ERR01, LN)
      IF (ERR01) GO TO 5
C
      CALL ENFFT(NMSUB, NFFT, 2, N, LYFFT, NFFT2, HEAD, ERR02)
      NF = NFFT2/2
C
      CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT2, 9, HEAD, ERR03, LLYFFT)
C
      CALL EISGE(NMSUB, LLPER, LPER, NF, 9, HEAD, ERR04, LLPER)
C
      CALL EISGE(NMSUB, LLFREQ, LFREQ, NF, 9, HEAD, ERR05, LLFREQ)
C
      IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05) GO TO 5
      GO TO 10
C
    5 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   10 CONTINUE
C
      CALL PGMMN (YFFT, N, NFFT2, IEXTND, NF, PER, LPER, YFFT, FREQ,
     +   LFREQ, NPRT, NMSUB)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL PGMS (YFFT, N, NFFT, LYFFT,'/
     +  '      +           IEXTND, NF, PER, LPER, FREQ, LFREQ, NPRT)')
      END
*PGORD
      SUBROUTINE PGORD (PER, NPTS, YAXIS, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES CO-ORDINATES FOR THE PERIODOGRAM PLOT.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   NPRT,NPTS
C
C  ARRAY ARGUMENTS
      REAL
     +   PER(NPTS),YAXIS(NPTS)
C
C  LOCAL SCALARS
      REAL
     +   FPLM
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC IABS,LOG10
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C        IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE,
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .EQ.  1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE.
C        IF NPRT .GE.  2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C     INTEGER NPTS
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES
C        ARE ESTIMATED.
C     REAL PER(NPTS)
C        THE ARRAY CONTAINING THE PERIODOGRAM VALUES.
C     REAL YAXIS(NPTS)
C        THE Y CO-ORDINATES FOR THE PERIODOGRAM PLOTS.
C
      FPLM = R1MACH(2)
C
C     THE FIRST VALUE SHOULD BE ZERO, SO NO ATTEMPT IS MADE TO PLOT IT.
C
      YAXIS(1) = FPLM
C
      DO 10 I = 2, NPTS
         YAXIS(I) = FPLM
         IF (PER(I) .LE. 0.0E0) GO TO 10
            YAXIS(I) = PER(I)
            IF (IABS(NPRT) .EQ. 1) YAXIS(I) = 10.0E0*LOG10(YAXIS(I))
   10 CONTINUE
C
      RETURN
C
      END
*PGOUT
      SUBROUTINE PGOUT (YAXIS, XAXIS, NPTS, NPRT, NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES THE PERIODOGRAM PLOTS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   NPRT,NPTS
C
C  ARRAY ARGUMENTS
      REAL
     +   XAXIS(NPTS),YAXIS(NPTS)
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      REAL
     +   FPLM,XMISS,XMN,XMX,YMN,YMX
      INTEGER
     +   ILOG,IPRT
      LOGICAL
     +   ERROR
C
C  LOCAL ARRAYS
      REAL
     +   YMISS(1)
      INTEGER
     +   ISYM(1)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPLMT,PPMN,VERSP,VPLMT,VPMN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,IABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C       AN ERROR FLAG
C     REAL FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER ILOG
C        ...
C     INTEGER IPRT
C        THE LOGICAL UNIT NUMBER FOR THE OUTPUT.
C     INTEGER ISYM(1)
C        A DUMMY ARRAY FOR THE PAGE PLOTS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE.
C     INTEGER NPRT
C        THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE
C        IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM ON A LOG-LINEAR SCALE,
C        IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE,
C        IF NPRT .EQ.  0, THE OUTPUT IS SUPPRESSED,
C        IF NPRT .GE.  1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE
C                         PERIODOGRAM IN DECIBELS ON A LINEAR SCALE.
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     REAL XAXIS(NPTS)
C        THE X CO-ORDINATES FOR THE PAGE PLOTS.
C     REAL XMISS
C        THE VALUE USED TO SPECIFY IF THE PERIODOGRAM VALUE WAS
C        LESS THAN OR EQUAL TO ZERO.
C     REAL XMN, XMX
C        ...
C     REAL YAXIS(NPTS)
C        THE Y CO-ORDINATES FOR THE SPECTRAL PLOTS.
C     REAL YMISS(1)
C        THE VALUE USED TO SPECIFY IF AN PERIODOGRAM VALUE WAS
C        LESS THAN OR EQUAL TO ZERO.
C     REAL YMN, YMX
C
C
      FPLM = R1MACH(2)
C
      XMISS = FPLM
      YMISS(1) = FPLM
C
C     SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH.
C
      CALL IPRINT (IPRT)
C
      CALL VERSP(.TRUE.)
      IF (IABS(NPRT).EQ.1) THEN
         WRITE (IPRT, 1010)
      ELSE
         WRITE (IPRT, 1000)
      END IF
C
      IF (ABS(NPRT).EQ.1) THEN
        ILOG = 0
      ELSE
        ILOG = 1
      END IF
      IF (NPRT.GE.1) THEN
C
C       PLOT VERTICAL PLOTS
C
        CALL VPLMT(YAXIS, YMISS, NPTS, 1, NPTS, 0.0E0, 0.0E0, YMN, YMX,
     +    ERROR, NMSUB, .TRUE., 1)
        IF (.NOT.ERROR)
     +    CALL VPMN(YAXIS(2), YMISS, NPTS-1, 1, NPTS, 1, 0, ISYM, 1, 0,
     +    YMN, YMX, 0.5E0/(NPTS-1), 0.5E0/(NPTS-1),
     +   .TRUE., ILOG, -1, 0)
      ELSE
C
C       PLOT PAGE PLOTS
C
        CALL PPLMT(YAXIS, YMISS, XAXIS, XMISS, NPTS, 1, NPTS,
     +    0.0E0, 0.0E0, YMN, YMX, 0.0E0, 0.5E0, XMN, XMX,
     +    ERROR, NMSUB, .TRUE.)
        IF (.NOT.ERROR) THEN
          CALL PPMN (YAXIS, YMISS, XAXIS, XMISS, NPTS, 1, NPTS, 0,
     +      ISYM, 1, 0, -1, YMN, YMX, XMN, XMX, .TRUE., ILOG)
          WRITE(IPRT, 1030)
        END IF
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (' SAMPLE PERIODOGRAM')
 1010 FORMAT (' SAMPLE PERIODOGRAM (IN DECIBELS)')
C1020 FORMAT (5H+FREQ/
C    1   7H PERIOD, 9X, 3HINF, 7X, 3H10., 4X, 2H5., 8X, 6H3.3333, 4X,
C    2   3H2.5, 4X, 2H2.)
 1030 FORMAT (5H+FREQ/
     +   7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X,
     +   2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X,
     +   6H2.2222, 4X, 2H2.)
C
      END
*PLINE
      SUBROUTINE PLINE(IMIN, IMAX, ISYMBL, LINE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE DEFINES ONE LINE OF A PLOT STRING FOR THE
C     VERTICAL PLOT ROUTINES.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IMAX,IMIN
      CHARACTER
     +   ISYMBL*1
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   LINE(103)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IMAX
C        THE LARGEST LOCATION IN THE PLOT STRING BEING DEFINED.
C     INTEGER IMIN
C        THE SMALLEST LOCATION IN THE PLOT STRING BEING DEFINED.
C     CHARACTER*1 ISYMBL
C        THE PLOTTING SYMBOL BEING USED.
C     CHARACTER*1 LINE(103)
C        THE VECTOR USED FOR THE PLOT STRING.
C
      DO 10 I = IMIN, IMAX
         LINE(I) = ISYMBL
   10 CONTINUE
      RETURN
      END
*PLTCHK
      SUBROUTINE PLTCHK (YM, YMMISS, X, XMISS, N, M, IYM, MULTI,
     +   ILOG, YLB, YUB, XLB, XUB, NMSUB, MISS, XCHECK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS PLOT FAMILY ROUTINE CHECKS FOR ERRORS IN THE PARAMETER LISTS
C     OF THE MULTIPLE PLOT ROUTINES
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,IYM,M,N
      LOGICAL
     +   MISS,MULTI,XCHECK
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   NV
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,ERR06,ERR07,ERR08,ERR09,HEAD
C
C  LOCAL ARRAYS
      INTEGER
     +   ILOGXY(2)
      CHARACTER
     +   LIYM(8)*1,LM(8)*1,LN(8)*1,LONE(8)*1,LX(8)*1,LXLB(8)*1,
     +   LXUB(8)*1,LY(8)*1,LYLB(8)*1,LYM(8)*1,LYUB(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ERAGT,ERAGTM,ERSGT,ERVGT,ERVGTM,PRTCNT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05, ERR06, ERR07, ERR08,
C    1   ERR09
C        VALUES 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 IERR
C        THE COMMON VARIABLE USED AS AN ERROR FLAG
C        IF = 0 THEN NO ERORRS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER ILOGXY(2)
C        ...
C     INTEGER IYM
C        ACTUAL ROW DIMENSION OF YM DECLARED IN USERS MAIN PROGRAM
C     CHARACTER*1 LIYM(8), LM(8), LN(8), LONE(8), LX(8), LXLB(8),
C    *  LXUB(8), LY(8), LYLB(8), LYM(8), LYUB(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE INPUT PARAMETERS(S)
C        CHECKED FOR ERRORS.
C     INTEGER M
C        THE NUMBER OF VECTORS IN YM
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING
C        ROUTINE HAS AN M PREFIX (TRUE) OR NOT (FALSE).
C     INTEGER N
C        THE LENGTH OF THE VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND IN THE X AND Y AXIS ARRAYS.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     LOGICAL XCHECK
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER X-AXIS VALUES
C        ARE TO BE CHECKED (XCHECK = .TRUE.) OR NOT (XCHECK = .FALSE.)
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y (VERTICAL) COORDINATES.
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR EACH COLUMN OF YM.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +   LIYM(1),   LIYM(2),   LIYM(3),   LIYM(4),   LIYM(5),   LIYM(6)
     + /     'I',       'Y',       'M',       ' ',       ' ',       ' '/
      DATA LIYM(7), LIYM(8)
     +   /     ' ',     ' '/
      DATA
     +     LM(1),     LM(2),     LM(3),     LM(4),     LM(5),     LM(6)
     + /     'M',       ' ',       ' ',       ' ',       ' ',       ' '/
      DATA   LM(7),   LM(8)
     +   /     ' ',     ' '/
      DATA
     +     LN(1),     LN(2),     LN(3),     LN(4),     LN(5),     LN(6)
     + /     'N',       ' ',       ' ',       ' ',       ' ',       ' '/
      DATA   LN(7),   LN(8)
     +   /     ' ',     ' '/
      DATA   LONE(1),  LONE(2),  LONE(3),  LONE(4),  LONE(5),  LONE(6),
     +       LONE(7),  LONE(8)/'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/
      DATA
     +     LX(1),     LX(2),     LX(3),     LX(4),     LX(5),     LX(6)
     + /     'X',       ' ',       ' ',       ' ',       ' ',       ' '/
      DATA   LX(7),   LX(8)
     +   /     ' ',     ' '/
      DATA
     +   LXLB(1),   LXLB(2),   LXLB(3),   LXLB(4),   LXLB(5),   LXLB(6)
     + /     'X',       'L',       'B',       ' ',       ' ',       ' '/
      DATA LXLB(7), LXLB(8)
     +   /     ' ',     ' '/
      DATA
     +   LXUB(1),   LXUB(2),   LXUB(3),   LXUB(4),   LXUB(5),   LXUB(6)
     + /     'X',       'U',       'B',       ' ',       ' ',       ' '/
      DATA LXUB(7), LXUB(8)
     +   /     ' ',     ' '/
      DATA
     +     LY(1),     LY(2),     LY(3),     LY(4),     LY(5),     LY(6)
     + /     'Y',       ' ',       ' ',       ' ',       ' ',       ' '/
      DATA   LY(7),   LY(8)
     +   /     ' ',     ' '/
      DATA
     +   LYLB(1),   LYLB(2),   LYLB(3),   LYLB(4),   LYLB(5),   LYLB(6)
     + /     'Y',       'L',       'B',       ' ',       ' ',       ' '/
      DATA LYLB(7), LYLB(8)
     +   /     ' ',     ' '/
      DATA
     +    LYM(1),    LYM(2),    LYM(3),    LYM(4),    LYM(5),    LYM(6)
     + /     'Y',       'M',       ' ',       ' ',       ' ',       ' '/
      DATA  LYM(7),  LYM(8)
     +   /     ' ',     ' '/
      DATA
     +   LYUB(1),   LYUB(2),   LYUB(3),   LYUB(4),   LYUB(5),   LYUB(6)
     + /     'Y',       'U',       'B',       ' ',       ' ',       ' '/
      DATA LYUB(7), LYUB(8)
     +   /     ' ',     ' '/
C
C     COMMENCE BODY OF ROUTINE
C
      IERR = 0
      HEAD = .TRUE.
C
C     NUMBER OF POINTS MUST BE AT LEAST 1
C
      CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERR01, LONE)
C
C     THERE MUST BE AT LEAST 1 COLUMN OF VECTORS
C
      CALL EISGE(NMSUB, LM, M, 1, 2, HEAD, ERR02, LONE)
C
C     THE ACTUAL LENGTH OF YM MUST EQUAL OR EXCEED THE NUMBER OF
C     OBSERVATIONS
C
      ERR03 = .TRUE.
      IF (.NOT.ERR01)
     +   CALL EISGE(NMSUB, LIYM, IYM, N, 3, HEAD, ERR03, LN)
C
C     IF THIS IS A LOG PLOT CHECK FOR NON-POSITIVE VALUES IN DATA
C
      IF (ERR01 .OR. ERR02 .OR. ERR03) IERR = 1
      IF (ILOG .LE. 0) RETURN
C
      ERR04 = .FALSE.
      ERR05 = .FALSE.
      ERR06 = .FALSE.
      ERR07 = .FALSE.
      ERR08 = .FALSE.
      ERR09 = .FALSE.
C
      CALL PRTCNT (MAX(0,ILOG),2,ILOGXY)
      IF ((ILOGXY(1).NE.0) .AND. XCHECK) THEN
        IF (.NOT.ERR01) THEN
C
C         IF X AXIS IS LOG SCALE, CHECK FOR NEGATIVE X AXIS VALUES
C
          IF (MISS) THEN
            CALL ERVGTM(NMSUB, LX, X, XMISS, N, 0.0E0, 0, HEAD, 1,
     +        NV, ERR04, LX)
          ELSE
            CALL ERVGT(NMSUB, LX, X, N, 0.0E0, 0, HEAD, 1, NV, ERR04,
     +        LX)
          END IF
        END IF
C
        IF (XLB.LT.XUB) THEN
C
C         CHECK FOR NEGATIVE PLOT BOUNDS
C
          CALL ERSGT(NMSUB, LXLB, XLB, 0.0E0, 1, HEAD, ERR05, LXLB)
          CALL ERSGT(NMSUB, LXUB, XUB, 0.0E0, 1, HEAD, ERR06, LXUB)
        END IF
      END IF
      IF (ILOGXY(2).NE.0) THEN
        IF ((.NOT.ERR01) .AND. (.NOT.ERR02) .AND. (.NOT.ERR03)) THEN
C
C         IF Y AYIS IS LOG SCALE, CHECK FOR NEGATIVE Y AYIS VALUES
C
          IF (MISS) THEN
            IF (MULTI) THEN
              CALL ERAGTM(NMSUB, LYM, YM, YMMISS, N, M, IYM, 0.0E0, 0,
     +           HEAD, 1, NV, ERR04, LYM)
            ELSE
              CALL ERVGTM(NMSUB, LY, YM, YMMISS(1), N, 0.0E0, 0, HEAD,
     +           1, NV, ERR04, LY)
            END IF
          ELSE
            IF (MULTI) THEN
              CALL ERAGT(NMSUB, LYM, YM, N, M, IYM, 0.0E0, 0, HEAD,
     +           1, NV, ERR04, LYM)
            ELSE
              CALL ERVGT(NMSUB, LY, YM, N, 0.0E0, 0, HEAD, 1,
     +           NV, ERR04, LY)
            END IF
          END IF
        END IF
C
        IF (YLB.LT.YUB) THEN
C
C         CHECK FOR NEGATIVE PLOT BOUNDS
C
          CALL ERSGT(NMSUB, LYLB, YLB, 0.0E0, 1, HEAD, ERR05, LYLB)
          CALL ERSGT(NMSUB, LYUB, YUB, 0.0E0, 1, HEAD, ERR06, LYUB)
        END IF
      END IF
C
      IF (ERR04 .OR. ERR05 .OR. ERR06 .OR. ERR07 .OR. ERR08 .OR. ERR09)
     +   IERR = 1
C
      RETURN
C
      END
*PLTPLX
      SUBROUTINE PLTPLX(POINT, YMN, SCALE, IPOINT, IEND)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE POINT LOCATION IN THE PLOT STRING.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   POINT,SCALE,YMN
      INTEGER
     +   IEND,IPOINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IEND
C        THE NUMBER OF LOCATIONS IN THE PLOT STRING.
C     INTEGER IPOINT
C        THE LOCATION IN THE PLOT STRING OF THE VALUE BEING PLOTTED.
C     REAL POINT
C        THE VALUE TO BE PLOTTED.
C     REAL SCALE
C        THE SCALE INTERVAL OF THE PLOT.
C     REAL YMN
C        THE GRAPH AXIS LOWER LIMITS ACTUALLY USED.
C
      IPOINT = (POINT-YMN)/SCALE + 2.5
      IF (IPOINT .LT. 2) IPOINT = 1
      IF (IPOINT .GT. IEND) IPOINT = IEND
      RETURN
      END
*PLTSYM
      SUBROUTINE PLTSYM(IPTSYM, I, J, ISYM, N, IPOINT, LINE, ICOUNT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SUPPLIES THE APPROPRIATE PLOT SYMBOL FOR
C     THE PLOT LINE.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   I,IPOINT,IPTSYM,J,N
C
C  ARRAY ARGUMENTS
      INTEGER
     +   ICOUNT(103),ISYM(N)
      CHARACTER
     +   LINE(103)*1
C
C  LOCAL SCALARS
      INTEGER
     +   ISYMBL
C
C  LOCAL ARRAYS
      CHARACTER
     +   SYM(30)*1,SYM1(10)*1
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER ICOUNT(103)
C        THE NUMBER OF PLOT SYMBOLS AT EACH LOCATION.
C     INTEGER IPOINT
C        THE LOCATION IN THE PLOT STRING OF THE VALUE BEING PLOTTED.
C     INTEGER IPTSYM
C        AN INDICATOR VARIABLE USED TO DESIGNATE THE TYPE
C        OF PLOT.  IF IPTSYM = 1, THE PLOT IS A SYMPLE PAGE
C        OR VERTICAL PLOT.  IF IPTSYM = 2, THE PLOT IS A SYMBOL
C        PLOT.  IF IPTSYM = 3, THE PLOT IS A MULTIVARIATE PLOT.
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER ISYMBL
C        THE INDEX OF THE PLOT SYMBOL TO BE USED.
C     INTEGER J
C        AN INDEX VARIABLE.
C     CHARACTER*1 LINE(103)
C        THE VECTOR USED FOR THE PLOT STRING.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 SYM(30), SYM1(10)
C        THE PLOT SYMBOLS.
C
      DATA SYM( 1)/'+'/,SYM( 2)/'.'/,SYM( 3)/'*'/,SYM( 4)/'-'/,
     +     SYM( 5)/'A'/,SYM( 6)/'B'/,SYM( 7)/'C'/,SYM( 8)/'D'/,
     +     SYM( 9)/'E'/,SYM(10)/'F'/,SYM(11)/'G'/,SYM(12)/'H'/,
     +     SYM(13)/'I'/,SYM(14)/'J'/,SYM(15)/'K'/,SYM(16)/'L'/,
     +     SYM(17)/'M'/,SYM(18)/'N'/,SYM(19)/'O'/,SYM(20)/'P'/,
     +     SYM(21)/'Q'/,SYM(22)/'R'/,SYM(23)/'S'/,SYM(24)/'T'/,
     +     SYM(25)/'U'/,SYM(26)/'V'/,SYM(27)/'W'/,SYM(28)/'Y'/,
     +     SYM(29)/'Z'/,SYM(30)/'Z'/
      DATA SYM1(1)/'1'/,SYM1(2)/'2'/,SYM1(3)/'3'/,SYM1(4)/'4'/,
     +     SYM1(5)/'5'/,SYM1(6)/'6'/,SYM1(7)/'7'/,SYM1(8)/'8'/,
     +     SYM1(9)/'9'/,SYM1(10)/'X'/
C
      ICOUNT(IPOINT) = ICOUNT(IPOINT) + 1
      IF (ICOUNT(IPOINT) .EQ. 1) GO TO 5
C
      ISYMBL = MIN(ICOUNT(IPOINT), 10)
      LINE(IPOINT) = SYM1(ISYMBL)
      RETURN
C
    5 CONTINUE
      GO TO (10, 20, 30), IPTSYM
C
   10 LINE(IPOINT) = SYM(1)
      RETURN
C
   20 ISYMBL = MIN(29, MAX(1, ISYM(I)))
      LINE(IPOINT) = SYM(ISYMBL)
      RETURN
C
   30 ISYMBL = MIN(29, MAX(1, J+4))
      LINE(IPOINT) = SYM(ISYMBL)
C
      RETURN
      END
*POLAR
      SUBROUTINE POLAR (AMPL, PHAS, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE CONVERTS THE PAIR OF SERIES AMPL AND PHAS
C     FROM THE REAL AND IMAGINARY PARTS OF A SERIES OF COMPLEX
C     NUMBERS TO THEIR MAGNITUDES AND PHASES.  THE CONVERSION IS
C     DONE IN PLACE.
C
C     WRITTEN BY  -  PETER BLOOMFIELD
C                    FOURIER ANALSERIESSIS OF TIME SERIES- AN
C                       INTRODUCTION
C                    JOHN WILESERIES AND SONS, NEW SERIESORK, 1976
C                    PAGE 150
C     ADAPTED FOR STARPAC BY  -  JANET R. DONALDSON
C                                 STATISTICAL ENGINEERING DEVISION
C                                 NATIONAL BUREAU OF STANDARDS
C                                 BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   AMPL(N),PHAS(N)
C
C  LOCAL SCALARS
      REAL
     +   PHASE,R
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ATAN2,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AMPL(N)
C        THE ARRAY IN WHICH THE AMPLITUDES ARE STORED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     REAL PHAS(N)
C        THE ARRAY IN WHICH THE PRIMARY PHASE ESTIMATES ARE RETURNED.
C     REAL PHASE
C        THE PHASE COMPONENT OF THE DEMODULATED SERIES.
C     REAL R
C        THE AMPLITUDE COMPONENT OF THE DEMODULATED SERIES.
C
      DO 10 I = 1, N
         R = SQRT(AMPL(I)*AMPL(I) + PHAS(I)*PHAS(I))
         PHASE = 0.0E0
         IF (R .NE. 0.0E0) PHASE = ATAN2(PHAS(I), AMPL(I))
         AMPL(I) = R
         PHAS(I) = PHASE
   10 CONTINUE
      RETURN
      END
*PPC
      SUBROUTINE PPC(YM, X, N, ILOG, ISIZE, NOUT, YLB, YUB, XLB, XUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT (LONG CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,N,NOUT
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XMISS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'P',       'P',       'C',       ' ',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      XMISS = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 0
      MISS = .FALSE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL PPC (Y, X, N, ILOG,'/
     +   '      +          ISIZE, NOUT, YLB, YUB, XLB, XUB)')
      END
*PPCNT
      SUBROUTINE PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLING ROUTINE FOR USER CALLED PAGE PLOT ROUTINES
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,ISCHCK,ISIZE,IYM,LISYM,M,N,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(*)
      INTEGER
     +   ISYM(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XMN,XMX,YMN,YMX
      LOGICAL
     +   ERROR,XCHECK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL PLTCHK,PPLMT,PPMN,VERSP
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        A VALUE INDICATING WHETHER AN ERROR WAS DETECTEC (TRUE)
C        OR NOT (FALSE).
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(LISYM)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING, NOT USED IN SOME CASES
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     LOGICAL XCHECK
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER X-AXIS VALUES
C        ARE TO BE CHECKED (XCHECK = .TRUE.) OR NOT (XCHECK = .FALSE.)
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XMN, XMX
C        THE X-AXIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        VECTOR OF OBSERVATIONS FOR THE Y (VERTICAL) COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YMN, YMX
C        THE Y-AYIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     COMMENCE BODY OF ROUTINE
C
      XCHECK = .TRUE.
      CALL PLTCHK (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +   YLB, YUB, XLB, XUB, NMSUB, MISS, XCHECK)
C
      IF (IERR.EQ.0) THEN
C
C       DETERMINE THE BOUNDS FOR THE X AND Y AXIS AND COMPLETE ERROR
C       CHECKING
C
        CALL PPLMT (YM, YMMISS, X, XMISS, N, M, IYM, YLB, YUB, YMN, YMX,
     +    XLB, XUB, XMN, XMX, ERROR, NMSUB, MISS)
C
        IF (ERROR) THEN
          IERR = 1
        ELSE
C
C       PRINT PLOT
C
        IF (ISIZE.LE.9) THEN
          CALL VERSP(.TRUE.)
        ELSE
          CALL VERSP(.FALSE.)
        END IF
        CALL PPMN (YM, YMMISS, X, XMISS, N, M, IYM, ISCHCK, ISYM,
     +    LISYM, ISIZE, NOUT, YMN, YMX, XMN, XMX, MISS, ILOG)
C
        END IF
      END IF
C
      RETURN
C
      END
*PP
      SUBROUTINE PP(YM, X, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT (SHORT CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'P',       'P',       ' ',       ' ',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      XMISS = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 0
      ISIZE = -1
      NOUT = 0
      MISS = .FALSE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL PP (Y, X, N)')
      END
*PPFCHS
      REAL FUNCTION PPFCHS(P, NU)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS FUNCTION IS A VERSION OF DATAPAC SUBROUTINE CHSPPF, WITH
C     MODIFICATIONS TO FACILITATE CONVERSION TO DOUBLE PRECISION
C     AUTOMATICALLY USING THE NAG, INC., CODE APT, AND TO CORRESPOND
C     TO STARPAC CONVENTIONS.
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE CHI-SQUARED DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THE CHI-SQUARED DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND ITS PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN REFERENCES 2, 3, AND 4 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     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0E0 (INCLUSIVELY)
C                                AND 1.0E0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPFCHS = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPFCHS FOR THE CHI-SQUARED DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--DECEMBER 2, 1985  (JRD) UNLESS AN INPUT ARGUMENT ERROR C
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --P SHOULD BE BETWEEN 0.0E0 (INCLUSIVELY)
C                   AND 1.0E0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     Fortran LIBRARY SUBROUTINES NEEDED--EXP, LOG.
C     MODE OF INTERNAL OPERATIONS--REAL.
C     LANGUAGE--ANSI Fortran.
C     ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS)
C               COMPARED TO THE KNOWN NU = 2 (EXPONENTIAL)
C               RESULTS, AGREEMENT WAS HAD OUT TO 6 SIGNIFICANT
C               DIGITS FOR ALL TESTED P IN THE RANGE P = .001 TO
C               P = .999.  FOR P = .95 AND SMALLER, THE AGREEMENT
C               WAS EVEN BETTER--7 SIGNIFICANT DIGITS.
C               (NOTE THAT THE TABULATED VALUES GIVEN IN THE WILK,
C               GNANADESIKAN, AND HUYETT REFERENCE BELOW, PAGE 20,
C               ARE IN ERROR FOR AT LEAST THE GAMMA = 1 CASE--
C               THE WORST DETECTED ERROR WAS AGREEMENT TO ONLY 3
C               SIGNIFICANT DIGITS (IN THEIR 8 SIGNIFICANT DIGIT TABLE)
C               FOR P = .999.)
C     REFERENCES--WILK, GNANADESIKAN, AND HUYETT, "PROBABILITY
C                 PLOTS FOR THE GAMMA DISTRIBUTION",
C                 TECHNOMETRICS, 1962, PAGES 1-15,
C                 ESPECIALLY PAGES 3-5.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 257, FORMULA 6.1.41,
C                 AND PAGES 940-943.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 166-206.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 46-51.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE  301-921-2315
C     ORIGINAL VERSION--SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C
C---------------------------------------------------------------------
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   P
      INTEGER
     +   NU
C
C  LOCAL SCALARS
      REAL
     +   A,AJ,B,C,CUT1,CUT2,CUTOFF,DEN,DX,FP,GAMMA,
     +   PCALC,SUM,TERM,XDEL,XLOWER,XMAX,XMID,XMIN,XMIN0,XUPPER,
     +   Z,Z2,Z3,Z4,Z5
      INTEGER
     +   ICOUNT,ILOOP,IPRT,J,MAXIT
C
C  LOCAL ARRAYS
      REAL
     +   D(10)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP,LOG
C
C
      DATA C/0.918938533204672741E0/
      DATA D(3),D(4),D(5)
     +  /+0.793650793650793651E-3,
     +   -0.595238095238095238E-3,
     +   +0.8417508417508417151E-3/
      DATA D(6),D(7),D(8),D(9),D(10)
     +  /-0.191752691752691753E-2,
     +   +0.641025641025641025E-2,
     +   -0.2955065359147712418E-1,
     +   +0.179644372368830573E0,
     +   -0.139243221690590111E1/
C
      D(1) = 1.0E0/12.0E0
      D(2) = 1.0E0/360.0E0
C
      CALL IPRINT (IPRT)
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF (P.LT.0.0E0 .OR. P.GE.1.0E0) THEN
         WRITE(IPRT,1010)
         WRITE(IPRT,1030) P
         PPFCHS = 0.0E0
         RETURN
      END IF
      IF(NU.LT.1) THEN
         WRITE(IPRT,1020)
         WRITE(IPRT,1040) NU
         PPFCHS = 0.0E0
         RETURN
      END IF
C
C-----START POINT-----------------------------------------------------
C
C     EXPRESS THE CHI-SQUARED DISTRIBUTION PERCENT POINT
C     FUNCTION IN TERMS OF THE EQUIVALENT GAMMA
C     DISTRIBUTION PERCENT POINT FUNCTION,
C     AND THEN EVALUATE THE LATTER.
C
      FP = P
      GAMMA = NU/2.0E0
      MAXIT = 10000
C
C     COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE
C     NBS APPLIED MATHEMATICS SERIES REFERENCE.
C     THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE.
C     IT IS USED IN THE CALCULATION OF THE CDF BASED ON
C     THE TENTATIVE VALUE OF THE PPFCHS IN THE ITERATION.
C
      Z = GAMMA
      DEN = 1.0E0
  150 IF(Z.LT.10.0E0) THEN
         DEN = DEN*Z
         Z = Z+1.0E0
         GO TO 150
      END IF
      Z2 = Z*Z
      Z3 = Z*Z2
      Z4 = Z2*Z2
      Z5 = Z2*Z3
      A = (Z-0.5E0)*LOG(Z)-Z+C
      B = D(1)/Z + D(2)/Z3 + D(3)/Z5 + D(4)/(Z2*Z5) + D(5)/(Z4*Z5) +
     +    D(6)/(Z*Z5*Z5) + D(7)/(Z3*Z5*Z5) + D(8)/(Z5*Z5*Z5) +
     +    D(9)/(Z2*Z5*Z5*Z5)
C     G = EXP(A+B)/DEN
C
C     DETERMINE LOWER AND UPPER LIMITS ON THE DESIRED 100P
C     PERCENT POINT.
C
      ILOOP = 1
C     XMIN0 = (FP*GAMMA*G)**(1.0E0/GAMMA)
      XMIN0 = EXP((1.0E0/GAMMA)*(LOG(FP)+LOG(GAMMA)+(A+B)-LOG(DEN)))
      XMIN = XMIN0
      XLOWER = XMIN
      XMID = XMIN
      XUPPER = XMIN
      ICOUNT = 1
  350 CONTINUE
      XMAX = ICOUNT*XMIN0
      DX = XMAX
      GO TO 600
  360 IF(PCALC.LT.FP) THEN
         XMIN = XMAX
         ICOUNT = ICOUNT+1
         IF(ICOUNT.LE.30000) GO TO 350
      END IF
      XMID = (XMIN+XMAX)/2.0E0
C
C     NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED.
C
      ILOOP = 2
      XLOWER = XMIN
      XUPPER = XMAX
      ICOUNT = 0
  550 DX = XMID
      GO TO 600
  560 IF(PCALC.NE.FP) THEN
         IF(PCALC.GT.FP) THEN
            XUPPER = XMID
            XMID = (XMID+XLOWER)/2.0E0
         ELSE
            XLOWER = XMID
            XMID = (XMID+XUPPER)/2.0E0
         END IF
         XDEL = XMID-XLOWER
         IF(XDEL.LT.0.0E0)XDEL = -XDEL
         ICOUNT = ICOUNT+1
         IF((XDEL.GE.0.0000000001E0) .AND. (ICOUNT.LE.100)) GO TO 550
      END IF
      PPFCHS = 2.0E0*XMID
      RETURN
C
C********************************************************************
C     THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE.
C     THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE
C     PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2
C     ITERATION LOOPS IN THE ABOVE CODE.
C
C     COMPUTE T-SUB-Q AS DEFINED ON PAGE 4 OF THE WILK, GNANADESIKAN,
C     AND HUYETT REFERENCE
C
  600 SUM = 1.0E0/GAMMA
      TERM = 1.0E0/GAMMA
      CUT1 = DX-GAMMA
      CUT2 = DX*10000000000.0E0
      DO 700 J=1,MAXIT
         AJ = J
         TERM = DX*TERM/(GAMMA+AJ)
         SUM = SUM+TERM
         CUTOFF = CUT1+(CUT2*TERM/SUM)
         IF (AJ.GT.CUTOFF) GO TO 750
  700 CONTINUE
      WRITE(IPRT,1050)MAXIT
      WRITE(IPRT,1060)P
      WRITE(IPRT,1070)NU
      WRITE(IPRT,1080)
      PPFCHS = 0.0E0
      RETURN
C
  750 CONTINUE
C     PCALC = (DX**GAMMA)*(EXP(-DX))*SUM/G
      PCALC = EXP(GAMMA*LOG(DX) + LOG(SUM) + LOG(DEN) - DX - A - B)
      IF (ILOOP.EQ.1) GO TO 360
      GO TO 560
C
 1010 FORMAT(' ',115H***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE
     + PPFCHS FUNCTION IS OUTSIDE THE ALLOWABLE (0,1  ) INTERVAL *****)
 1020 FORMAT(' ', 91H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE
     + PPFCHS FUNCTION IS NON-POSITIVE *****  )
 1030 FORMAT(' ', 35H***** THE VALUE OF THE ARGUMENT IS ,E15.8,6H *****)
 1040 FORMAT(' ', 35H***** THE VALUE OF THE ARGUMENT IS ,I8   ,6H *****)
 1050 FORMAT(' ',48H*****ERROR IN INTERNAL OPERATIONS IN THE PPFCHS ,
     + 43HFUNCTION--THE NUMBER OF ITERATIONS EXCEEDS ,I7)
 1060 FORMAT(' ',33H     THE INPUT VALUE OF P     IS ,E15.8)
 1070 FORMAT(' ',33H     THE INPUT VALUE OF NU    IS ,I8)
 1080 FORMAT(52H      THE OUTPUT VALUE OF PPFCHS HAS BEEN SET TO 0.0)
C
      END
*PPFF
      REAL FUNCTION PPFF(P, NU1, NU2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS FUNCTION IS A VERSION OF DATAPLOT SUBROUTINE FPPF,
C     WITH MODIFICATIONS NECESSARY TO CORRESPOND TO STARPAC CONVENTIONS.
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FOR THE F DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM
C              PARAMETERS = NU1 AND NU2.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0E0 AND 1.0E0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU1    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE NUMERATOR OF THE F RATIO.
C                                NU1 SHOULD BE POSITIVE.
C                     --NU2    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE DENOMINATOR OF THE F RATIO.
C                                NU2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPFF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPFF FOR THE F DISTRIBUTION
C             WITH DEGREES OF FREEDOM
C             PARAMETERS = NU1 AND NU2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN
C                   0.0E0 (INCLUSIVELY) AND 1.0E0 (EXCLUSIVELY).
C                 --NU1 SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --NU2 SHOULD BE A POSITIVE INTEGER VARIABLE.
C     LANGUAGE--ANSI Fortran.
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGES 946-947,
C                 FORMULAE 26.6.4, 26.6.5, 26.6.8, AND 26.6.15.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGE 83, FORMULA 20,
C                 AND PAGE 84, THIRD FORMULA.
C               --PAULSON, AN APPROXIMATE NORMAILIZATION
C                 OF THE ANALYSIS OF VARIANCE DISTRIBUTION,
C                 ANNALS OF MATHEMATICAL STATISTICS, 1942,
C                 NUMBER 13, PAGES 233-135.
C               --SCHEFFE AND TUKEY, A FORMULA FOR SAMPLE SIZES
C                 FOR POPULATION TOLERANCE LIMITS, 1944,
C                 NUMBER 15, PAGE 217.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE-- THIS ROUTINE WAS ADAPTED FROM DATAPLOT SUBROUTINE
C            FPPF WITH PERMISSION FROM THE AUTHOR.  DATAPLOT IS
C            A REGISTERED TRADEMARK.
C
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THIS LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI Fortran (1966)
C     VERSION NUMBER--82.3
C     ORIGINAL VERSION--MAY       1978.
C     UPDATED         --AUGUST    1979.
C     UPDATED         --DECEMBER  1981.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   P
      INTEGER
     +   NU1,NU2
C
C  LOCAL SCALARS
      REAL
     +   ANU1,ANU2,EXPF,PCALC,SDF,TOL,X,XDEL,XLOW,XMAX,
     +   XMID,XMIN,XN,XUP,ZN
      INTEGER
     +   IBUG,ICOUNT,IPRT,MAXIT
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFF,PPFNML
      EXTERNAL CDFF,PPFNML
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,EXP,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ANU1
C        THE (REAL) DEGREES OF FREEDOM IN THE NUMERATOR.
C     REAL ANU2
C        THE (REAL) DEGREES OF FREEDOM IN THE DENOMINATOR.
C     REAL EXPF
C        *
C     INTEGER IBUG
C        *
C     INTEGER ICOUNT
C        *
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MAXIT
C        *
C     INTEGER NU1
C        THE DEGREES OF FREEDOM IN THE NUMERATOR.
C     INTEGER  NU2
C        THE DEGREES OF FREEDOM IN THE DENOMINATOR.
C     REAL P
C        THE VALUE (BETWEEN 0.0E0 AND 1.0E0) AT WHICH THE PERCENT POINT
C        IS TO BE CALCULATED.
C     REAL PCALC
C        *
C     REAL SDF
C        *
C     REAL TOL
C        *
C     REAL X
C        *
C     REAL XDEL
C        *
C     REAL XLOW
C        *
C     REAL XMAX
C        *
C     REAL XMID
C        *
C     REAL XMIN
C        *
C     REAL XN
C        *
C     REAL XUP
C        *
C     REAL ZN
C        *
C
C---------------------------------------------------------------------
C
C     COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
C     COMMON /PRINT/IFEEDB,IPRINT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CALL IPRINT(IPRT)
C
      PPFF = 0.0E0
      IF (NU1.LE.0) GO TO 10
      IF (NU2.LE.0) GO TO 20
      IF (P.LT.0.0E0 .OR. P.GE.1.0E0) GO TO 30
      GO TO 40
   10 WRITE (IPRT,1010)
      WRITE (IPRT,1040) NU1
      PPFF = 0.0E0
      RETURN
   20 WRITE (IPRT,1020)
      WRITE (IPRT,1040) NU2
      PPFF = 0.0E0
      RETURN
   30 WRITE (IPRT,1000)
      WRITE (IPRT,1030) P
      PPFF = 0.0E0
      RETURN
   40 CONTINUE
C
C-----START POINT-----------------------------------------------------
C
      IBUG = 0.0E0
C
      TOL = 0.000001E0
      MAXIT = 100
      XMIN = 0.0E0
      XMAX = 10.0E30
      XLOW = XMIN
      XUP = XMAX
C
      ANU1 = NU1
      ANU2 = NU2
C
      EXPF = 0.5E0*((1.0E0/ANU2)-(1.0E0/ANU1))
      SDF = SQRT(0.5E0*((1.0E0/ANU2)+(1.0E0/ANU1)))
      ZN = PPFNML(P)
      XN = EXPF + ZN*SDF
      XMID = EXP(2.0E0*XN)
      IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID
C
      IF (P.EQ.0.0E0) GO TO 50
      GO TO 60
   50 CONTINUE
      PPFF = XMIN
      RETURN
   60 CONTINUE
C
      ICOUNT = 0
C
   70 CONTINUE
      X = XMID
      PCALC = CDFF(X,ANU1,ANU2)
      IF (PCALC.EQ.P) GO TO 130
      IF (PCALC.GT.P) GO TO 100
C
   80 CONTINUE
      XLOW = XMID
      X = XMID*2.0E0
      IF (X.GE.XUP) GO TO 90
      XMID = X
      IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID
      PCALC = CDFF(X,ANU1,ANU2)
      IF (PCALC.EQ.P) GO TO 130
      IF (PCALC.LT.P) GO TO 80
      XUP = X
   90 CONTINUE
      XMID = (XLOW+XUP)/2.0E0
      IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID
      GO TO 120
C
  100 CONTINUE
      XUP = XMID
      X = XMID/2.0E0
      IF (X.LE.XLOW) GO TO 110
      XMID = X
      IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID
      PCALC = CDFF(X,ANU1,ANU2)
      IF (PCALC.EQ.P) GO TO 130
      IF (PCALC.GT.P) GO TO 100
      XLOW = X
  110 CONTINUE
      XMID = (XLOW+XUP)/2.0E0
      IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID
C
  120 CONTINUE
      XDEL = ABS(XMID-XLOW)
      ICOUNT = ICOUNT + 1
      IF (XDEL.LT.TOL .OR. ICOUNT.GT.MAXIT) GO TO 130
      GO TO 70
C
  130 CONTINUE
      PPFF = XMID
C
      RETURN
 1000 FORMAT (' ', 49H***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO T,
     +   59HHE FPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ,
     +   5H*****)
 1010 FORMAT (' ', 49H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO T,
     +   42HHE FPPF   SUBROUTINE IS NON-POSITIVE *****)
 1020 FORMAT (' ', 49H***** FATAL ERROR--THE THIRD  INPUT ARGUMENT TO T,
     +   42HHE FCDF   SUBROUTINE IS NON-POSITIVE *****)
 1030 FORMAT (' ', 35H***** THE VALUE OF THE ARGUMENT IS , E15.8,
     +   6H *****)
 1040 FORMAT (' ', 35H***** THE VALUE OF THE ARGUMENT IS , I8, 6H *****)
 1050 FORMAT (' ', 7HXMID = , E15.7)
      END
*PPFNML
      REAL 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.0E0 AND 1.0E0, 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
      REAL
     +   P
C
C  LOCAL SCALARS
      REAL
     +   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     REAL ADEN, ANUM
C        *
C     REAL P
C        THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED
C     REAL P0, P1, P2, P3, P4
C        VARIOUS PARAMETERS USED IN THE APPROXIMATIONS.
C     REAL Q0, Q1, Q2, Q3, Q4
C        VARIOUS ADDITIONAL PARAMETERS USED IN THE APPROXIMATIONS.
C     REAL R
C        *
C     REAL T
C        *
C
      DATA P0, P1, P2, P3, P4
     +  /-.322232431088E0, -1.0E0, -.342242088547E0,
     +   -.204231210245E-1,-.453642210148E-4/
      DATA Q0, Q1, Q2, Q3, Q4
     +  /.993484626060E-1, .588581570495E0,
     +   .531103462366E0, .103537752850E0, .38560700634E-2/
C
C
      IF (P.NE.0.5E0) GO TO 30
      PPFNML = 0.0E0
      RETURN
C
   30 R = P
      IF (P.GT.0.5E0) R = 1.0E0 - R
      T = SQRT(-2.0E0*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.5E0) PPFNML = -PPFNML
C
      RETURN
C
      END
*PPFT
      REAL 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.0E0 (EXCLUSIVELY)
C                   AND 1.0E0 (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
      REAL
     +   P
      INTEGER
     +   IDF
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   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     REAL ARG
C        *
C     REAL B21
C        *
C     REAL B31, B32, B33, B34
C        *
C     REAL B41, B42, B43, B44, B45
C        *
C     REAL B51, B52, B53, B54, B55, B56
C        *
C     REAL C, CON
C        *
C     REAL DF
C        THE DEGREES OF FREEDOM.
C     REAL D1, D3, D5, D7, D9
C        *
C     INTEGER IDF
C        THE (INTEGER) DEGREES OF FREEDOM.
C     INTEGER IPASS
C        *
C     INTEGER MAXIT
C        *
C     REAL P
C        THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED.
C     REAL PI
C        THE VALUE OF PI.
C     REAL PPFN
C        THE NORMAL PERCENT POINT VALUE.
C     REAL S
C        *
C     REAL SQRT2
C        THE SQUARE ROOT OF TWO.
C        *
C     REAL TERM1, TERM2, TERM3, TERM4, TERM5
C        *
C     REAL Z
C        *
C
C     DEFINE CONSTANTS USED IN THE APPROXIMATIONS
C
      DATA B21 /4.0E0/
      DATA B31, B32, B33, B34 /96.0E0, 5.0E0, 16.0E0, 3.0E0/
      DATA B41, B42, B43, B44, B45
     +  /384.0E0, 3.0E0, 19.0E0, 17.0E0, -15.0E0/
      DATA B51, B52, B53, B54, B55, B56
     +   /9216.0E0, 79.0E0, 776.0E0, 1482.0E0,
     +   -1920.0E0, -945.0E0/
C
      CALL GETPI(PI)
C
      SQRT2 = SQRT(2.0E0)
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.0E0
      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.0E0
      TERM2 = 2.0E0*P - 1.0E0
      TERM3 = SQRT(P*(1.0E0-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.0E0/B21)*(D3+D1)/DF
      TERM3 = (1.0E0/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2)
      TERM4 = (1.0E0/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3)
      TERM5 = (1.0E0/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.5E0)
      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.0E0*C*C)
   70 CONTINUE
      PPFT = SQRT(DF)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE IDF = 4 CASE
C
   80 CON = 2.0E0*(P-0.5E0)
      ARG = PPFT/SQRT(DF)
      Z = ATAN(ARG)
      DO 90 IPASS=1,MAXIT
         S = SIN(Z)
         C = COS(Z)
         Z = Z - ((1.0E0+0.5E0*C*C)*S-CON)/(1.5E0*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.5E0)
      ARG = PPFT/SQRT(DF)
      Z = ATAN(ARG)
      DO 110 IPASS=1,MAXIT
         S = SIN(Z)
         C = COS(Z)
         Z = Z - (Z+(C+(2.0E0/3.0E0)*C*C*C)*S-CON)/((8.0E0/3.0E0)*C**4)
  110 CONTINUE
      PPFT = SQRT(DF)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE IDF = 6 CASE
C
  120 CON = 2.0E0*(P-0.5E0)
      ARG = PPFT/SQRT(DF)
      Z = ATAN(ARG)
      DO 130 IPASS=1,MAXIT
         S = SIN(Z)
         C = COS(Z)
         Z = Z - ((1.0E0+0.5E0*C*C+0.375E0*C**4)*S-CON)/
     +           ((15.0E0/8.0E0)*C**5)
  130 CONTINUE
      PPFT = SQRT(DF)*S/C
      RETURN
C
      END
*PPL
      SUBROUTINE PPL(YM, X, N, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT (LOG OPTION).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'P',       'P',       'L',       ' ',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      XMISS = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 0
      ISIZE = -1
      NOUT = 0
      MISS = .FALSE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL PPL (Y, X, N, ILOG)')
      END
*PPLMT
      SUBROUTINE PPLMT (YM, YMMISS, X, XMISS, N, M, IYM, YLB, YUB, YMN,
     +  YMX, XLB, XUB, XMN, XMX, ERROR, NMSUB, MISS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE PLOT LIMITS FOR PAGE PLOTS
C     WITH MISSING VALUES.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
C
      REAL
     +   XLB,XMISS,XMN,XMX,XUB,YLB,YMN,YMX,YUB
      INTEGER
     +   IYM,M,N
      LOGICAL
     +   ERROR,MISS
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N),YM(IYM,M),YMMISS(M)
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,II,IPRT,J
      LOGICAL
     +   HEAD,SETLMT,SKPROW
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      real r1mach
      EXTERNAL MVCHK
      external r1mach
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ADJLMT,EHDR,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        A VALUE INDICATING WHETHER AN ERROR WAS DETECTED (TRUE)
C        OR NOT (FALSE).
C     LOGICAL HEAD
C        PRINT HEADING (HEAD=TRUE) OR NOT (HEAD=FALSE).
C     INTEGER I, II
C        INDEXING VARIABLES.
C     INTEGER IPRT
C        ...
C     INTEGER IYM
C        ACTUAL ROW DIMENSION OF YM DECLARED IN THE USERS MAIN PROGRAM
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER M
C        THE NUMBER OF VECTORS IN YM
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS .
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     LOGICAL SETLMT
C        AN INDICATOR VARIABLE USED TO DETERMINE IF STARTING VALUES
C        FOR XMN, XMX, YMN, YMX HAVE BEEN FOUND.
C     LOGICAL SKPROW
C        AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER ALL
C        OBSERVATIONS IN A GIVEN ROW OF YM ARE UNUSED (TRUE)
C        OR NOT (FALSE).
C     REAL X(N)
C        THE ARRAY CONTAINING THE INDEPENDENT VARIABLE.
C     REAL XLB
C        THE USER SUPPLIED X-AXIS LOWER BOUND.
C     REAL XMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IS MISSING.
C        IF X(I) = XMISS, THE VALUE IS ASSUMED MISSING, OTHERWISE
C        IT IS NOT.
C     REAL XMN, XMX
C        THE X-AXIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL XUB
C        THE USER SUPPLIED X-AXIS UPPER BOUNDS.
C     REAL YLB
C        THE USER SUPPLIED Y-AXIS LOWER BOUND.
C     REAL YM(IYM,M)
C        THE ARRAY CONTAINING THE DEPENDENT VARIABLE(S).
C     REAL YMMISS(M)
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IS MISSING.
C        IF YM(I,J) = YMMISS(J), THE VALUE IS ASSUMED MISSING, OTHERWISE
C        IT IS NOT.
C     REAL YMN, YMX
C        THE Y-AXIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL YUB
C        THE USER SUPPLIED Y-AXIS UPPER BOUNDS.
C
      ERROR = .FALSE.
C
      IF ((XLB .LT. XUB) .AND. (YLB .LT. YUB)) THEN
C
C       SET LIMITS TO USER SPECIFIED VALUES
C
        XMN = XLB
        XMX = XUB
        YMN = YLB
        YMX = YUB
C
      ELSE
C
C       SET LIMITS TO RANGE OF VALUES WITHIN ANY USER SPECIFIED VALUES
C
        SETLMT = .FALSE.
        II = 1

        xmn =  r1mach(2)
        xmx = -r1mach(2)
        ymn =  r1mach(2)
        ymx = -r1mach(2)
C
C       FIND FIRST VALUE TO BE PLOTTED
C
        DO 20 I=1,N
           IF (MISS .AND. MVCHK(X(I),XMISS)) GO TO 20
           IF ((XLB.LT.XUB) .AND. ((X(I).LT.XLB) .OR.
     +        (XUB.LT.X(I)))) GO TO 20
           XMN = X(I)
           XMX = X(I)
           DO 10 J=1,M
              IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 10
              IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR.
     +           (YUB.LT.YM(I,J)))) GO TO 10
              IF (SETLMT) GO TO 5
              YMN = YM(I,J)
              YMX = YM(I,J)
              SETLMT = .TRUE.
              II = I + 1
              GO TO 10
    5         YMN = MIN(YMN, YM(I,J))
              YMX = MAX(YMX, YM(I,J))
   10      CONTINUE
           IF (SETLMT) GO TO 30
   20   CONTINUE
C
   30   IF (II.LE.1) THEN
C
C         NO VALUES TO BE PLOTTED.  PRINT ERROR MESSAGE
C
          ERROR = .TRUE.
          CALL IPRINT(IPRT)
          HEAD = .TRUE.
          CALL EHDR(NMSUB,HEAD)
          IF ((YLB.GE.YUB) .AND. (XLB.GE.XUB)) THEN
            WRITE (IPRT, 1010)
          ELSE
            WRITE (IPRT, 1020)
          END IF
          WRITE (IPRT, 1030)
C
        ELSE
C
C         FIND LIMITS FROM REMAINING VALUES
C
          IF (II.LE.N) THEN
            DO 50 I=II,N
               IF (MISS .AND. MVCHK(X(I),XMISS)) GO TO 50
               IF ((XLB.LT.XUB) .AND. ((X(I).LT.XLB) .OR.
     +            (XUB.LT.X(I)))) GO TO 50
               SKPROW = .TRUE.
               DO 40 J=1,M
                  IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 40
                  IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR.
     +               (YUB.LT.YM(I,J)))) GO TO 40
                  SKPROW = .FALSE.
                  YMN = MIN(YMN, YM(I,J))
                  YMX = MAX(YMX, YM(I,J))
   40          CONTINUE
               IF (SKPROW) GO TO 50
               XMN = MIN(XMN, X(I))
               XMX = MAX(XMX, X(I))
   50       CONTINUE
          END IF
        END IF
C
        IF (YLB.LT.YUB) THEN
C
C       SET Y AXIS LIMITS TO USER SUPPLIED VALUES
C
          YMN = YLB
          YMX = YUB
        ELSE
C
C       ADJUST Y AXIS LIMITS IF EQUAL
C
          IF (YMN .GE. YMX) CALL ADJLMT(YMN, YMX)
        END IF
C
        IF (XLB.LT.XUB) THEN
C
C       SET X AXIS LIMITS TO USER SUPPLIED VALUES
C
          XMN = XLB
          XMX = XUB
        ELSE
C
C         ADJUST X AXIS LIMITS IF EQUAL
C
          IF (XMN .GE. XMX) CALL ADJLMT(XMN, XMX)
C
        END IF
C
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT (/
     +   44H NO NON-MISSING PLOT COORDINATES WERE FOUND.)
 1020 FORMAT (/
     +   40H NO NON-MISSING VALUES WERE FOUND WITHIN,
     +   26H THE USER SUPPLIED LIMITS.)
 1030 FORMAT (/
     +   30H THE PLOT HAS BEEN SUPPRESSED.)
      END
*PPMC
      SUBROUTINE PPMC(YM, YMMISS, X, XMISS, N, ILOG, ISIZE, NOUT, YLB,
     +   YUB, XLB, XUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT FOR DATA WITH MISSING OBSERVATIONS (LONG CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,N,NOUT
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(1)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'P',       'P',       'M',       'C',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 0
      MISS = .TRUE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL PPMC (Y, YMISS, X, XMISS, N, ILOG,'/
     +   '      +           ISIZE, NOUT, YLB, YUB, XLB, XUB)')
      END
*PPM
      SUBROUTINE PPM(YM, YMMISS, X, XMISS, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT FOR DATA WITH MISSING OBSERVATIONS (SHORT CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XMISS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(1)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'P',       'P',       'M',       ' ',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 0
      ISIZE = -1
      NOUT = 0
      MISS = .TRUE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL PPM (Y, YMISS, X, XMISS, N)')
      END
*PPML
      SUBROUTINE PPML(YM, YMMISS, X, XMISS, N, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT FOR DATA WITH MISSING OBSERVATIONS (LOG OPTION).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XMISS
      INTEGER
     +   ILOG,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(1)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'P',       'P',       'M',       'L',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 0
      ISIZE = -1
      NOUT = 0
      MISS = .TRUE.
      LISYM = 1
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL PPML (Y, YMISS, X, XMISS, N, ILOG)')
      END
*PPMN
      SUBROUTINE PPMN (YM, YMMISS, X, XMISS, N, M, IYM, ISCHCK, ISYM,
     +  LISYM, ISIZE, NOUT, YMN, YMX, XMN, XMX, MISS, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN ROUTINE FOR PAGE PLOTS
C
C     WRITTEN BY  --
C                 JANET R. DONALDSON
C                 STATISTICAL ENGINEERING DIVISION/BOULDER
C                 NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  NOVEMBER 21, 1980
C
C     INPUT ARGUMENTS - (IN ORDER OF USAGE)
C
C        X  THE N VECTOR OF OBSERVATIONS FOR THE X
C           COORDINATES
C        Y  THE N BY M MATRIX OF OBSERVATIONS FOR THE Y (VERTICAL)
C           COORDINATES
C           THE ITH COLUMN IS PLOTTED USING THE FOLLOWING SYMBOL
C               1 = A    2 = B    3 = C    4 = D
C               5 = E    6 = F    7 = G    8 = H
C               9 = I   10 = J   11 = K   12 = L
C              13 = M   14 = N   15 = O   16 = P
C              17 = Q   18 = R   19 = S   20 = T
C              21 = U   22 = V   23 = W   24 = Y
C              25 (AND ABOVE) = Z
C           THE NUMBERS 1 TO 9 INDICATE MULTIPLE POINTS ON A GIVEN
C           PLOT LOCATION, WHERE THE NUMBER INDICATES HOW MANY POINTS
C           ARE REPRESENTED
C           NOTE THAT  X  IS NOT USED AS A PLOTTING SYMBOL EXCEPT TO
C           INDICATE THAT MORE THAN 9 POINTS FELL ON THE SAME PLOT
C           LOCATION
C        N  THE INTEGER NUMBER OF OBSERVATIONS TO BE PLOTTED (IN EACH
C           COLUMN)
C        M  THE NUMBER OF COLUMNS IN THE Y ARRAY TO BE PLOTTED VERSUS X
C           FOR THE CASE OF A VECTOR Y, M MUST BE EQUAL TO 1
C    IYM  THE ACTUAL INTEGER VALUE OF THE ROW DIMENSION OF THE Y ARRAY
C           WHEN Y IS A VECTOR (M.EQ.1) IYM SHOULD BE SET EQUAL TO N
C   ISCHCK  THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     ISYM  THE N VECTOR OF INTEGERS DETERMINING THE PLOTTING SYMBOLS TO
C           USED FOR THE S SERIES OF PLOTS, WHERE
C               1 = +    2 = .    3 = *    4 = -
C               5 = A    6 = B    7 = C    8 = D
C               9 = E   10 = F   11 = G   12 = H
C              13 = I   14 = J   15 = K   16 = L
C              17 = M   18 = N   19 = O   20 = P
C              21 = Q   22 = R   23 = S   24 = T
C              25 = U   26 = V   27 = W   28 = Y
C              29 (AND ABOVE) = Z
C           THE NUMBERS 1 TO 9 INDICATE MULTIPLE POINTS ON A GIVEN
C           PLOT LOCATION, WHERE THE NUMBER INDICATES HOW MANY POINTS
C           ARE REPRESENTED
C           NOTE THAT  X  IS NOT USED AS A PLOTTING SYMBOL EXCEPT TO
C           INDICATE THAT MORE THAN 9 POINTS FELL ON THE SAME PLOT
C           LOCATION
C    ISIZE  THE INTEGER CODE FOR THE PLOT SIZE, WHERE
C           0 INDICATES A PLOT 100 COL BY 50 ROWS
C           1 INDICATES A PLOT 50 COL BY  50 ROWS
C     NOUT  THE INTEGER VALUE INDICATING HOW MANY OF THE POINTS WHICH
C           FELL OUTSIDE OF THE GRAPH LIMITS ARE TO BE LISTED
C           IF XLB.EQ.XUB AND YLB.EQ.YUB, NOUT SHOULD BE SET TO ZERO
C     XLB  THE MINIMUM VALUE OF X TO BE PLOTTED(IE, THE LOWER BOUND FOR
C           THE X AXIS), WHERE IF XLB=XUB THE ROUTINE WILL DETERMINE
C           THIS VALUE FROM THE MINIMUM VALUE OF THE X VECTOR
C     XUB  THE MAXIMUM VALUE OF X TO BE PLOTTED(IE, THE UPPER BOUND FOR
C           THE X AXIS), WHERE IF XLB=XUB THE ROUTINE WILL DETERMINE
C           THIS VALUE FROM THE MAXIMUM VALUE OF THE X VECTOR
C     YLB  THE MINIMUM VALUE OF Y TO BE PLOTTED(IE, THE LOWER BOUND FOR
C           THE Y AXIS), WHERE IF YLB=YUB THE ROUTINE WILL DETERMINE
C           THIS VALUE FROM THE MINIMUM VALUE OF THE Y VECTOR
C     YUB  THE MAXIMUM VALUE OF Y TO BE PLOTTED(IE, THE UPPER BOUND FOR
C           THE Y AXIS), WHERE IF YLB=YUB THE ROUTINE WILL DETERMINE
C           THIS VALUE FROM THE MAXIMUM VALUE OF THE Y VECTOR
C     ILOG  THE INTEGER INDICATOR VARIABLE USED TO DETERMINE WHETHER
C           THE Y AXIS SCALE IS TO BE LOG OR NOT
C           IF ILOG.EQ.0, THE SCALE IS NOT LOG
C           IF ILOG.NE.0, THE SCALE IS LOG
C
C
C     ADDITIONAL VARIABLES USED - (IN ALPHABETICAL ORDER)
C
C    ALINE  THE VECTOR OF THE CURRENT PLOT LINE
C   ALPHAI  THE PLOT AXIS SYMBOL I
C   AXISCH  THE Y A AXIS SYMBOL TO BE USED FOR THE CURRENT LINE,
C           EITHER I OR -
C   ALPHAX  THE PLOTTING SYMBOL X DESIGNATING MORE THAN 9 POINTS FELL ON
C           A SINGLE PLOTTING LOCATION
C    BLANK  THE PLOTTING SYMBOL BLANK
C     DELX  THE RANGE OF THE X AXIS
C     DELY  THE RANGE OF THE Y AXIS
C   HYPHEN  THE PLOT AXIS SYMBOL -
C       IC  THE COUNT OF THE NUMBER OF VALUES FALLING OUTSIDE OF THE
C           GRAPH BOUNDS
C     ICOL  THE COLUMN LOCATION FOR THE PLOT LINE
C     IOUT  THE MINIMUM OF NOUT OR 50, INDICATING HOW MANY OF THE
C           POINTS WHICH FELL OUTSIDE OF THE GRAPH LIMITS WILL ACTUALLY
C           BE LISTED
C   IPCODE  THE INTEGER CODE, USED IN ERROR CHECKING, WHICH DETERMINES
C           WHICH PLOT ROUTINE HAS BEEN CALLED
C      IPR  THE UNIT NUMBER OF THE PRINTER
C    ITEST  THE INDICATOR VARIABLE FOR WHETHER THE X AXIS LABELS ARE
C           PRINTED IN E OR F FORMAT
C      KSS  AN INTEGER VECTOR USED IN DETERMINING THE PLOT SYMBOL
C           NEEDED
C       NN  THE NUMBER OF Y LABELS TO BE LISTED ON THE LEFT AXIS,
C           (DEPENDENT ON THE GRAPH SIZE)
C   NUMCOL  THE INTEGER VALUE OF THE NUMBER OF COLUMNS IN THE GRAPH
C   NUMLAB  THE INTEGER NUMBER OF X LABELS TO BE LISTED AT THE BOTTOM
C           OF THE GRAPH (DEPENDENT ON GRAPH SIZE)
C   NUMROW  THE INTEGER NUMBER OF ROWS IN THE GRAPH
C      SYM  THE VECTOR OF PLOT SYMBOL ASSIGNMENTS (SEE IS ABOVE)
C     SYM1  THE VECTOR OF INTEGER VALUES USED TO INDICATE MULTIPLE
C           POINTS ON THE SAME PLOT LOCATION
C     TEMP  THE ARRAY OF VALUES TO BE PRINTED WHICH FALL OUTSIDE THE
C           GRAPH LIMITS
C   XLABEL  THE VECTOR OF X AXIS LABELS
C       XMN  THE MINIMUM X VALUE TO BE PLOTTED, COMPUTED FROM DATA OR
C           ASSIGNED BY XLB
C   XWIDTH  THE VALUE OF AN INDIVIDUAL X AXIS GRAPH INTERVAL
C       XMX  THE MAXIMUM X VALUE TO BE PLOTTED, COMPUTED FROM DATA OR
C           ASSIGNED BY XUB
C   YLABEL  THE VALUE OF THE Y AXIS LABEL TO BE PRINTED
C   YLOWER  THE LOWER BOUND FOR Y VALUES TO BE PLOTTED ON THE CURRENT
C           LINE
C       YMN  THE MINIMUM Y VALUE TO BE PLOTTED, COMPUTED FROM DATA OR
C           ASSIGNED BY YLB
C   YUPPER  THE UPPER BOUND FOR Y VALUES TO BE PLOTTED ON THE CURRENT
C           LINE
C   YWIDTH  THE VALUE OF AN INDIVIDUAL Y AXIS GRAPH INTERVAL
C       YMX  THE MAXIMUM Y VALUE TO BE PLOTTED, COMPUTED FROM DATA OR
C           ASSIGNED BY YUB
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XMISS,XMN,XMX,YMN,YMX
      INTEGER
     +   ILOG,ISCHCK,ISIZE,IYM,LISYM,M,N,NOUT
      LOGICAL
     +   MISS
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N),YM(IYM,M),YMMISS(M)
      INTEGER
     +   ISYM(LISYM)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   DELX,DELY,TN,TX,XDMN,XDMX,XWIDTH,XX,YDMN,YDMX,YL,YLOWER,
     +   YUPPER,YWIDTH,YY
      INTEGER
     +   I,IC,ICOL,IK,ILOGX,ILOGY,IOUT,IPRT,IROW,IT,ITEST,J,JCOL,K,
     +   L,NLABLX,NLABLY,NLU,NN,NUMCOL,NUMCP2,NUMROW
      CHARACTER
     +   ALPHAI*1,ALPHAX*1,AXISCH*1,BLANK*1,HYPHEN*1,FMT*4,
     +   XLFMT*205,XLFMT2*205
C
C  LOCAL ARRAYS
      REAL
     +   TEMP(50,2),XLABEL(20),YLABEL(20)
      INTEGER
     +   ALINE(105),ILOGXY(2),ISIZXY(2),ISPACE(20),KSS(101)
      CHARACTER
     +   CLINE(105)*1,ITEMP(50)*1,SYM(30)*1,SYM1(9)*1
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      EXTERNAL MVCHK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LOGLMT,PRTCNT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG10,MAX,MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ALINE(105)
C     CHARACTER*1 ALPHAI, ALPHAX
C     CHARACTER*1 AXISCH
C     CHARACTER*1 BLANK
C     CHARACTER*1 CLINE(105)
C     REAL DELX, DELY
C     CHARACTER FMT*4
C        THE FORMAT FOR THE X-AXIS LABELS
C     CHARACTER*1 HYPHEN
C     INTEGER I, IC, ICOL, IERR, IK
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER ILOGX
C        THE VALUES OF P AS SPECIFIED BY ILOG.
C     INTEGER ILOGXY(2)
C        THE VALUES OF P AND Q AS SPECIFIED BY ILOG.
C     INTEGER ILOGY
C        THE VALUES OF Q AS SPECIFIED BY ILOG.
C     INTEGER IOUT
C     INTEGER IPRT, IROW
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISIZXY(2)
C     INTEGER ISPACE(20)
C        THE SPACING FOR THE X-AXIS LABELS
C     INTEGER ISYM(LISYM)
C     INTEGER IT
C     CHARACTER*1 ITEMP(50)
C     INTEGER ITEST
C     INTEGER IYM
C     INTEGER J, JCOL
C     INTEGER K
C     INTEGER KSS(101)
C     INTEGER L
C     INTEGER LISYM
C     INTEGER M
C     LOGICAL MISS
C     INTEGER N
C     INTEGER NLABLX, NLABLY, NLU
C     INTEGER NN, NOUT, NUMCOL, NUMCP2, NUMROW
C     CHARACTER*1 SYM(30), SYM1(9)
C     REAL TEMP(50, 2)
C     REAL TN, TX
C     REAL X(N)
C     REAL XDMN, XDMX
C        THE X-AXIS DATA LIMITS ACTUALLY USED.
C     REAL XLABEL(20)
C        THE X-AXIS LABLES.
C     CHARACTER XLFMT*205, XLFMT2*205
C        THE FORMATS USED TO PRINT THE X-AXIS
C     REAL XMISS, XMN, XMX, XWIDTH, XX
C     REAL YDMN, YDMX
C        THE Y-AXIS DATA LIMITS ACTUALLY USED.
C     REAL YL
C     REAL YLABEL(20)
C        THE Y-AXIS LABLES.
C     REAL YLOWER
C     REAL YM(IYM, M)
C     REAL YMMISS(M)
C     REAL YMN, YMX, YUPPER, YWIDTH, YY
C
      DATA BLANK/' '/,HYPHEN/'-'/,ALPHAI/'I'/,ALPHAX/'X'/
      DATA SYM( 1)/'+'/,SYM( 2)/'.'/,SYM( 3)/'*'/,SYM( 4)/'-'/,
     +     SYM( 5)/'A'/,SYM( 6)/'B'/,SYM( 7)/'C'/,SYM( 8)/'D'/,
     +     SYM( 9)/'E'/,SYM(10)/'F'/,SYM(11)/'G'/,SYM(12)/'H'/,
     +     SYM(13)/'I'/,SYM(14)/'J'/,SYM(15)/'K'/,SYM(16)/'L'/,
     +     SYM(17)/'M'/,SYM(18)/'N'/,SYM(19)/'O'/,SYM(20)/'P'/,
     +     SYM(21)/'Q'/,SYM(22)/'R'/,SYM(23)/'S'/,SYM(24)/'T'/,
     +     SYM(25)/'U'/,SYM(26)/'V'/,SYM(27)/'W'/,SYM(28)/'Y'/,
     +     SYM(29)/'Z'/,SYM(30)/'Z'/
      DATA SYM1(1)/'1'/,SYM1(2)/'2'/,SYM1(3)/'3'/,SYM1(4)/'4'/,
     +     SYM1(5)/'5'/,SYM1(6)/'6'/,SYM1(7)/'7'/,SYM1(8)/'8'/,
     +     SYM1(9)/'9'/
C
      CALL IPRINT(IPRT)
C
C     DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT
C
      CALL PRTCNT(MAX(0,ISIZE),2,ISIZXY)
      IF (ISIZXY(1).EQ.0) THEN
        NUMCOL=101
      ELSE
        NUMCOL = 51
      END IF
      IF (ISIZXY(2).EQ.0) THEN
        NUMROW = 51
      ELSE
        NUMROW = 26
      END IF
C
      NUMCP2 = NUMCOL + 2
      NN=(NUMROW-1)/5
C
C     ADJUST FOR LOG PLOTS IF NECESSARY AND FIND AXIS LABELS
C
      CALL PRTCNT (MAX(0,ILOG),2,ILOGXY)
      ILOGX = ILOGXY(1)
      ILOGY = ILOGXY(2)
      CALL LOGLMT (ILOGY, YMN, YMX, YLABEL, NUMROW, 5, DELY, YWIDTH,
     +  NLABLY, YDMN, YDMX)
      CALL LOGLMT (ILOGX, XMN, XMX, XLABEL, NUMCOL, 10, DELX, XWIDTH,
     +  NLABLX, XDMN, XDMX)
C
C     TEST FOR FORMAT FOR Y AXIS LABELS
C
      ITEST=0
      TX=YMX
      TN=YMN
      IF (ILOGY.EQ.0) GO TO 190
      TX=10.0E0**TX
      TN=10.0E0**TN
  190 IF ((TN .GE. 1.0E6 .OR. TN .LE. (-1.0E5)) .OR.
     +   (ABS(TN).GT.0.0E0.AND.ABS(TN).LT.0.001E0)) ITEST=1
      IF ((TX .GE. 1.0E6 .OR. TX .LE. (-1.0E5)) .OR.
     +   (ABS(TX).GT.0.0E0.AND.ABS(TX).LT.0.001E0)) ITEST=1
C
C     BLANK OUT THE PLOT PRINT LINE CLINE
C
      DO 200 ICOL=1,105
         CLINE(ICOL)=BLANK
  200 CONTINUE
C
C     WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT
C
      DO 210 ICOL=1,NUMCOL
         CLINE(ICOL)=HYPHEN
  210 CONTINUE
      CLINE(1)=ALPHAI
      IF (ILOGX.EQ.0) THEN
        DO 215 ICOL=11,NUMCOL,10
           CLINE(ICOL)=ALPHAI
  215   CONTINUE
      ELSE
        DO 216 IK = NLABLX, 1, -1
          ICOL = ((LOG10(XLABEL(IK))-XMN)/XWIDTH)+1.5E0
          CLINE(ICOL) = ALPHAI
  216   CONTINUE
      END IF
      CLINE(NUMCOL+1)=HYPHEN
      CLINE(NUMCOL+2)=BLANK
      WRITE (IPRT, 1004) HYPHEN,(CLINE(I),I=1,NUMCOL),HYPHEN
      DO 217 ICOL=1,105
         CLINE(ICOL)=BLANK
  217 CONTINUE
C
C     DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME.
C
      L=-1
      IK=1
      DO 320 IROW=1,NUMROW
         L=L+1
         IF (L.GT.NN) L=1
         DO 235 ICOL=1,NUMCOL
            ALINE(ICOL)=0
            KSS(ICOL)=0
  235    CONTINUE
         YUPPER=YMX+(1.5E0-IROW)*YWIDTH
         YLOWER=YMX+(0.5E0-IROW)*YWIDTH
      DO 255 I = 1, N
C
         IF (MISS .AND. MVCHK(X(I), XMISS)) GO TO 255
C
         IF (ILOGX.EQ.0) THEN
           XX=X(I)
         ELSE
           XX=LOG10(X(I))
         END IF
         DO 250 J=1,M
C
            IF (MISS .AND. MVCHK(YM(I,J), YMMISS(J))) GO TO 250
               IF (ILOGY.EQ.0) THEN
                 YY=YM(I,J)
               ELSE
                 YY=LOG10(YM(I,J))
               END IF
               IF (((YLOWER.LE.YY).AND.(YY.LT.YUPPER)) .AND.
     +             ((YY.GE.YDMN).AND.(YY.LE.YDMX))) THEN
                  IF ((XX.GE.XDMN) .AND. (XX.LE.XDMX)) THEN
                     ICOL=((XX-XMN)/XWIDTH)+1.5E0
                     ALINE(ICOL) = ALINE(ICOL) + 1
C     SIMPLE PLOTTING (PLT)
                     KSS(ICOL)=1
C     SYMBOL PLOTS (SPLT)
                     IF (ISCHCK .EQ. 1) KSS(ICOL) = ISYM(I)
C     MULTIPLE PLOTS (MPLT)
                     IF (ISCHCK .EQ. 2) KSS(ICOL) = J + 4
                     IF (KSS(ICOL).GT.30) KSS(ICOL)=30
                     IF (KSS(ICOL).LT.1) KSS(ICOL)=1
                  END IF
               END IF
  250       CONTINUE
  255    CONTINUE
         DO 290 ICOL=1,NUMCOL
            IF (ALINE(ICOL).EQ.0) THEN
              CLINE(ICOL)=BLANK
            ELSE
              IF (ALINE(ICOL).EQ.1) THEN
                K=KSS(ICOL)
                CLINE(ICOL)=SYM(K)
              ELSE
                IF (ALINE(ICOL).LE.9) THEN
                  CLINE(ICOL)=SYM1(ALINE(ICOL))
                ELSE
                  CLINE(ICOL)=ALPHAX
                END IF
              END IF
            END IF
  290    CONTINUE
         CLINE(NUMCOL+2)=HYPHEN
         AXISCH=HYPHEN
         IF (ILOGY.EQ.0) THEN
           YL = YLABEL(IK)
         ELSE
           YL = LOG10(YLABEL(IK))
         END IF
         IF ((YLOWER.GT.YL) .OR. (YL.GE.YUPPER)) THEN
C
C          PRINT LINE WITHOUT LABEL
C
           CLINE(NUMCP2)=ALPHAI
           WRITE(IPRT, 1008) ALPHAI, (CLINE(ICOL), ICOL=1,NUMCP2)
         ELSE
C
C          PRINT LINE WITH LABEL
C
           IF (ITEST.EQ.0) THEN
             WRITE(IPRT,1006) YLABEL(IK),AXISCH,
     +         (CLINE(ICOL),ICOL=1,NUMCP2)
           ELSE
             WRITE(IPRT,1007) YLABEL(IK),AXISCH,
     +         (CLINE(ICOL),ICOL=1,NUMCP2)
           END IF
           IK=IK+1
         END IF
  320 CONTINUE
C
C     WRITE OUT THE BOTTOM HORIZONTAL AXIS AND THE X AXIS LABELS.
C
      DO 330 ICOL=1,NUMCOL
         CLINE(ICOL)=HYPHEN
  330 CONTINUE
      CLINE(1)=ALPHAI
      IF (ILOGX.EQ.0) THEN
        NLU = NLABLX+1
        DO 340 ICOL=NUMCOL,1,-10
           CLINE(ICOL)=ALPHAI
           NLU = NLU - 1
           ISPACE(NLU) = 1
  340   CONTINUE
      ELSE
        JCOL = 1
        CLINE(JCOL) = ALPHAI
        NLU = NLABLX
        DO 345 IK = NLABLX, 1, -1
          ICOL = ((LOG10(XLABEL(IK))-XMN)/XWIDTH)+1.5
          CLINE(ICOL) = ALPHAI
          IF (ICOL-JCOL.GE.10) THEN
            ISPACE(NLU) = ICOL-JCOL-9
            NLU = NLU - 1
            XLABEL(NLU) = XLABEL(IK)
            JCOL = ICOL
          END IF
  345   CONTINUE
      END IF
      CLINE(NUMCOL+1)=HYPHEN
      CLINE(NUMCOL+2)=BLANK
C
      WRITE(IPRT, 1004) HYPHEN, (CLINE(ICOL), ICOL = 1, NUMCP2)
C
C     CHECK X-AXIS LABELS FOR FORMAT
C
      FMT = 'F9.4'
      DO 350 I=1,NLABLX
        IF (((ABS(XLABEL(I)).GT.0.0E0) .AND. (ABS(XLABEL(I)).LT.0.01E0))
     +      .OR.
     +      ((XLABEL(I).GE.1.0E4) .OR. (XLABEL(I).LE.(-1.0E3)))) THEN
          FMT = 'E9.4'
           GO TO 355
         END IF
  350 CONTINUE
  355 CONTINUE
      WRITE(XLFMT2,1000) NLABLX-NLU
      WRITE(XLFMT,XLFMT2) (FMT, ISPACE(I), I=NLABLX,NLU+1,-1), FMT
      WRITE(IPRT, XLFMT) (XLABEL(I),I=NLABLX,NLU,-1)
C
C     DETERMINE VALUES TO BE LISTED IF OUTSIDE OF AXIS LIMITS.
C
      IC = 0
      IOUT = MIN(NOUT,50)
      IF (IOUT.GE.0) THEN
        DO 180 I = 1, N
C
          IF (MISS .AND. MVCHK(X(I), XMISS)) GO TO 180
C
          IF (ILOGX.EQ.0) THEN
            XX = X(I)
          ELSE
            XX = LOG10(X(I))
          END IF
           DO 175 J=1,M
C
              IF (MISS .AND. MVCHK(YM(I,J), YMMISS(J))) GO TO 175
C
              IF (ILOGY.EQ.0) THEN
                YY = YM(I,J)
              ELSE
                YY = LOG10(YM(I,J))
              END IF
C
              IF (((YDMN .LE. YY) .AND. (YY .LE. YDMX)) .AND.
     +            ((XDMN .LE. XX) .AND. (XX .LE. XDMX))) GO TO 175
C
              IC=IC+1
              IF (IC.GT.IOUT) GO TO 175
              TEMP(IC,1)=X(I)
              TEMP(IC,2)=YM(I,J)
              IT=1
              IF (ISCHCK.EQ.1) IT=ISYM(I)
              IF (ISCHCK.EQ.2) IT=J+4
              IF (IT.LT.1) IT=1
              IF (IT.GT.30) IT=30
              ITEMP(IC) = SYM(IT)
  175      CONTINUE
  180   CONTINUE
      END IF
C
C     CHECK FOR POINTS OUTSIDE OF GRAPH LIMITS AND LIST IF REQUESTED
C     THE TOTAL NUMBER OF POINTS TO BE PLOTTED IS N*M
C
      IF (IC.EQ.0) RETURN
      IF (IOUT .LT. 0) RETURN
      WRITE (IPRT, 1010) IC
      IF (IOUT.LE.0) RETURN
      WRITE (IPRT, 1016)
      IF (IC.LE.IOUT) GO TO 360
      IC=IOUT
      WRITE(IPRT, 1011) IOUT
      GO TO 370
  360 WRITE(IPRT, 1012)
  370 WRITE(IPRT, 1013) (TEMP(I,1), TEMP(I,2), ITEMP(I), I = 1, IC)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT ('(''(14X'',', I2, '('', '', A4, '','', I2, ''X''),',
     +  ''', '', A4, '')'')')
 1004 FORMAT (' ',16X, A1, 105A1)
 1006 FORMAT(4X,F11.4,1X,A1,1X,105A1)
 1007 FORMAT (' ', E14.7, 1X, A1, 1X, 105A1)
 1008 FORMAT (' ', 15X, A1, 1X, 105A1)
 1010 FORMAT(16X,6H**NOTE,I4,43H VALUES FELL OUTSIDE THE SPECIFIED LIMIT
     +S**)
 1011 FORMAT ('1', 15X, 10HTHE FIRST , I3,
     +   35H VALUES OUTSIDE THE PLOT LIMITS ARE/ 22X,
     + 33H X               Y            SYM)
 1012 FORMAT ('1', 15X, 38HTHE VALUES OUTSIDE THE PLOT LIMITS ARE/ 22X,
     + 33H X               Y            SYM)
 1013 FORMAT (15X,2E15.8,9X,A1)
 1016 FORMAT (16X, 22HSEE NEXT PAGE FOR LIST)
C
      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
      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
*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
      REAL
     +   J(NN,P),R(N)
C
C  LOCAL SCALARS
      REAL
     +   T
      INTEGER
     +   I,K,L,NL1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   DOTPRD
      EXTERNAL DOTPRD
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     *****PARAMETERS.
C     INTEGER NN, N, P, IERR
C     REAL 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     REAL T
C/
C     *****FUNCTIONS.
C     EXTERNAL DOTPRD
C     REAL DOTPRD
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
*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
      REAL
     +   ALPHA(N),QR(NM,N),SUM(N)
      INTEGER
     +   IPIVOT(N)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   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     REAL  QR(NM,N),ALPHA(N),SUM(N)
C     *****LOCAL VARIABLES.
C     INTEGER I,J,JBAR,K,K1,MINUM,MK1
C     REAL  ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL,
C    1        RKTOL1,SUMJ
C     *****FUNCTIONS.
C/+
C     INTEGER MIN
C     REAL              ABS,SQRT
C/
C     EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM
C     REAL 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     REAL ONE, P01, P99, ZERO
      DATA ONE/1.0E0/, P01/0.01E0/, P99/0.99E0/, ZERO/0.0E0/
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.0E0/, UFETA/0.0E0/
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
*R9GMIT
      REAL FUNCTION R9GMIT (A, X, ALGAP1, SGNGAM, ALX)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C COMPUTE TRICOMI-S INCOMPLETE GAMMA FUNCTION FOR SMALL X.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL A,ALGAP1,ALX,SGNGAM,X
C
C  LOCAL SCALARS
      REAL AE,AEPS,ALG2,ALGS,BOT,EPS,FK,S,SGNG2,T,TE
      INTEGER K,M,MA
C
C  EXTERNAL FUNCTIONS
      REAL ALNGAM,R1MACH
      EXTERNAL ALNGAM,R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,EXP,FLOAT,LOG,SIGN
C
      DATA EPS, BOT / 2*0.0 /
C
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1))
C
      IF (X.LE.0.0) CALL XERROR ('R9GMIT  X SHOULD BE GT 0', 24, 1, 2)
C
      MA = A + 0.5
      IF (A.LT.0.0) MA = A - 0.5
      AEPS = A - FLOAT(MA)
C
      AE = A
      IF (A.LT.(-0.5)) AE = AEPS
C
      T = 1.0
      TE = AE
      S = T
      DO 20 K=1,200
        FK = K
        TE = -X*TE/FK
        T = TE/(AE+FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 30
 20   CONTINUE
      CALL XERROR (  'R9GMIT  NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SE
     1RIES', 54, 2, 2)
C
 30   IF (A.GE.(-0.5)) THEN
         ALGS = -ALGAP1 + LOG(S)
      ELSE
C
         ALGS = -ALNGAM(1.0+AEPS) + LOG(S)
         S = 1.0
         M = -MA - 1
         IF (M.EQ.0) GO TO 50
         T = 1.0
         DO 40 K=1,M
            T = X*T/(AEPS-FLOAT(M+1-K))
            S = S + T
            IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40      CONTINUE
C
 50      R9GMIT = 0.0
         ALGS = -FLOAT(MA)*LOG(X) + ALGS
         IF (S.NE.0.0 .AND. AEPS.NE.0.0) THEN
            SGNG2 = SGNGAM*SIGN(1.0,S)
            ALG2 = -X - ALGAP1 + LOG(ABS(S))
C
            IF (ALG2.GT.BOT) R9GMIT = SGNG2*EXP(ALG2)
            IF (ALGS.GT.BOT) R9GMIT = R9GMIT + EXP(ALGS)
            RETURN
         END IF
      END IF
      R9GMIT = EXP(ALGS)
      RETURN
C
      END
*R9LGIC
      REAL FUNCTION R9LGIC (A, X, ALX)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C COMPUTE THE LOG COMPLEMENTARY INCOMPLETE GAMMA FUNCTION FOR LARGE X
C AND FOR A .LE. X.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL A,ALX,X
C
C  LOCAL SCALARS
      REAL EPS,FK,P,R,S,T,XMA,XPA
      INTEGER K
C
C  EXTERNAL FUNCTIONS
      REAL R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG
C
      DATA EPS / 0.0 /
C
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
C
      XPA = X + 1.0 - A
      XMA = X - 1.0 - A
C
      R = 0.0
      P = 1.0
      S = P
      DO 10 K=1,200
        FK = K
        T = FK*(A-FK)*(1.0+R)
        R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 20
 10   CONTINUE
      CALL XERROR (  'R9LGIC  NO CONVERGENCE IN 200 TERMS OF CONTINUED F
     1RACTION', 57, 1, 2)
C
 20   R9LGIC = A*ALX - X + LOG(S/XPA)
C
      RETURN
      END
*R9LGIT
      REAL FUNCTION R9LGIT (A, X, ALGAP1)
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C COMPUTE THE LOG OF TRICOMI-S INCOMPLETE GAMMA FUNCTION WITH PERRON-S
C CONTINUED FRACTION FOR LARGE X AND FOR A .GE. X.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL A,ALGAP1,X
C
C  LOCAL SCALARS
      REAL A1X,AX,EPS,FK,HSTAR,P,R,S,SQEPS,T
      INTEGER K
C
C  EXTERNAL FUNCTIONS
      REAL R1MACH
      EXTERNAL R1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG,SQRT
C
      DATA EPS, SQEPS / 2*0.0 /
C
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (SQEPS.EQ.0.0) SQEPS = SQRT(R1MACH(4))
C
      IF (X.LE.0.0 .OR. A.LT.X) CALL XERROR (
     1  'R9LGIT  X SHOULD BE GT 0.0 AND LE A', 35, 2, 2)
C
      AX = A + X
      A1X = AX + 1.0
      R = 0.0
      P = 1.0
      S = P
      DO 20 K=1,200
        FK = K
        T = (A+FK)*X*(1.0+R)
        R = T/((AX+FK)*(A1X+FK)-T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 30
 20   CONTINUE
      CALL XERROR (  'R9LGIT  NO CONVERGENCE IN 200 TERMS OF CONTINUED F
     1RACTION', 57, 3, 2)
C
 30   HSTAR = 1.0 - X*S/A1X
      IF (HSTAR.LT.SQEPS) CALL XERROR (
     1  'R9LGIT  RESULT LESS THAN HALF PRECISION', 39, 1, 1)
C
      R9LGIT = -X - ALGAP1 - LOG(HSTAR)
C
      RETURN
      END
*R9LGMC
      REAL FUNCTION R9LGMC (X)
C AUGUST 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C
C COMPUTE THE LOG GAMMA CORRECTION FACTOR FOR X .GE. 10.0 SO THAT
C  LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL X
C
C  LOCAL SCALARS
      REAL XBIG,XMAX
      INTEGER NALGM
C
C  LOCAL ARRAYS
      REAL ALGMCS(6)
C
C  EXTERNAL FUNCTIONS
      REAL CSEVL,R1MACH
      INTEGER INITS
      EXTERNAL CSEVL,R1MACH,INITS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP,LOG,MIN,SQRT
C
C
C SERIES FOR ALGM       ON THE INTERVAL  0.          TO  1.00000D-02
C                                        WITH WEIGHTED ERROR   3.40E-16
C                                         LOG WEIGHTED ERROR  15.47
C                               SIGNIFICANT FIGURES REQUIRED  14.39
C                                    DECIMAL PLACES REQUIRED  15.86
C
      DATA ALGMCS( 1) /    .1666389480 45186E0 /
      DATA ALGMCS( 2) /   -.0000138494 817606E0 /
      DATA ALGMCS( 3) /    .0000000098 108256E0 /
      DATA ALGMCS( 4) /   -.0000000000 180912E0 /
      DATA ALGMCS( 5) /    .0000000000 000622E0 /
      DATA ALGMCS( 6) /   -.0000000000 000003E0 /
C
      DATA NALGM, XBIG, XMAX / 0, 2*0.0 /
C
      IF (NALGM.NE.0) GO TO 10
      NALGM = INITS (ALGMCS, 6, R1MACH(3))
      XBIG = 1.0/SQRT(R1MACH(3))
      XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) )
C
 10   IF (X.LT.10.0) CALL XERROR ('R9LGMC  X MUST BE GE 10', 23, 1, 2)
      IF (X.GE.XMAX) GO TO 20
C
      R9LGMC = 1.0/(12.0*X)
      IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X
      RETURN
C
 20   R9LGMC = 0.0
      CALL XERROR ('R9LGMC  X SO BIG R9LGMC UNDERFLOWS', 34, 2, 1)
      RETURN
C
      END
*RANDN
      REAL FUNCTION RANDN(JD)
C***BEGIN PROLOGUE  RANDN (ORIGINALLY RNOR)
C***DATE WRITTEN   810915
C***REVISION DATE  900315
C***CATEGORY NO.  L6A14
C***KEYWORDS  RANDOM NUMBERS, UNIFORM RANDOM NUMBERS
C***AUTHOR    KAHANER, DAVID
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST
C
C             MARSAGLIA, GEORGE
C             COMPUTER SCIENCE DEPT., WASH STATE UNIV
C
C             MODIFIED BY -
C             DONALDSON, JANET
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST
C
C***PURPOSE  GENERATES QUASI NORMAL RANDOM NUMBERS, WITH MEAN ZERO AND
C             UNIT STANDARD DEVIATION, AND CAN BE USED WITH ANY COMPUTER
C             WITH INTEGERS AT LEAST AS LARGE AS 32767.
C***DESCRIPTION
C
C       RANDN GENERATES QUASI NORMAL RANDOM NUMBERS WITH ZERO MEAN AND
C       UNIT STANDARD DEVIATION.
C       IT CAN BE USED WITH ANY COMPUTER WITH INTEGERS AT LEAST AS
C       LARGE AS 32767.
C
C
C   USE
C       FIRST TIME....
C                   Z = RANDN(JD)
C                     HERE JD IS ANY  N O N - Z E R O  INTEGER.
C                     THIS CAUSES INITIALIZATION OF THE PROGRAM
C                     AND THE FIRST RANDOM NUMBER TO BE RETURNED AS Z.
C       SUBSEQUENT TIMES...
C                   Z = RANDN(0)
C                     CAUSES THE NEXT RANDOM NUMBER TO BE RETURNED AS Z.
C
C=======================================================================
C
C    NOTE: USERS WHO WISH TO TRANSPORT THIS PROGRAM TO OTHER
C           COMPUTERS SHOULD READ THE FOLLOWING ....
C
C   MACHINE DEPENDENCIES...
C      MDIG = A LOWER BOUND ON THE NUMBER OF BINARY DIGITS AVAILABLE
C              FOR REPRESENTING INTEGERS, INCLUDING THE SIGN BIT.
C              THIS MUST BE AT LEAST 16, BUT CAN BE INCREASED IN
C              LINE WITH REMARK A BELOW.
C
C   REMARKS...
C     A. THIS PROGRAM CAN BE USED IN TWO WAYS:
C        (1) TO OBTAIN REPEATABLE RESULTS ON DIFFERENT COMPUTERS,
C            SET 'MDIG' TO THE SMALLEST OF ITS VALUES ON EACH, OR,
C        (2) TO ALLOW THE LONGEST SEQUENCE OF RANDOM NUMBERS TO BE
C            GENERATED WITHOUT CYCLING (REPEATING) SET 'MDIG' TO THE
C            LARGEST POSSIBLE VALUE.
C     B. THE SEQUENCE OF NUMBERS GENERATED DEPENDS ON THE INITIAL
C          INPUT 'JD' AS WELL AS THE VALUE OF 'MDIG'.
C          IF MDIG=16 ONE SHOULD FIND THAT
C            THE FIRST EVALUATION
C              Z=RANDN(87) GIVES  Z=-.40079207...
C            THE SECOND EVALUATION
C              Z=RANDN(0) GIVES   Z=-1.8728870...
C            THE THIRD EVALUATION
C              Z=RANDN(0) GIVES   Z=1.8216004...
C            THE FOURTH EVALUATION
C              Z=RANDN(0) GIVES   Z=.69410355...
C            THE THOUSANDTH EVALUATION
C              Z=RANDN(0) GIVES   Z=.96782424...
C
C***REFERENCES  MARSAGLIA & TSANG, "A FAST, EASILY IMPLEMENTED
C                 METHOD FOR SAMPLING FROM DECREASING OR
C                 SYMMETRIC UNIMODAL DENSITY FUNCTIONS", TO BE
C                 PUBLISHED IN SIAM J SISC 1983.
C***ROUTINES CALLED  I1MACH,XERROR
C***END PROLOGUE  RANDN
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   JD
C
C  LOCAL SCALARS
      REAL
     +   AA,B,C,C1,C2,ONE,P5,PC,RMAX,S,X,XN,Y
      INTEGER
     +   I,I1,J,J0,J1,JSEED,K0,K1,M1,M2,MDIG
C
C  LOCAL ARRAYS
      REAL
     +   V(65),W(65)
      INTEGER
     +   M(17)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RANDU
      INTEGER
     +   I1MACH
      EXTERNAL RANDU,I1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,EXP,LOG,MIN,MOD,REAL,SIGN
C
C  SAVE STATEMENT
      SAVE I1,J1,M,M1,M2,RMAX
C
      DATA AA,B,C,RMAX/12.37586E0,0.4878992E0,12.67706E0,3.0518509E-5/
      DATA C1,C2,PC,XN/0.9689279E0,1.301198E0,0.1958303E-1,2.776994E0/
      DATA (V(I),I=1,15)/0.3409450E0,0.4573146E0,0.5397793E0,
     +     0.6062427E0,0.6631691E0,0.7136975E0,0.7596125E0,0.8020356E0,
     +     0.8417227E0,0.8792102E0,0.9148948E0,0.9490791E0,0.9820005E0,
     +     1.0138492E0,1.0447810E0/
      DATA (V(I),I=16,30)/1.0749254E0,1.1043917E0,1.1332738E0,
     +     1.1616530E0,1.1896010E0,1.2171815E0,1.2444516E0,1.2714635E0,
     +     1.2982650E0,1.3249008E0,1.3514125E0,1.3778399E0,1.4042211E0,
     +     1.4305929E0,1.4569915E0/
      DATA (V(I),I=31,45)/1.4834526E0,1.5100121E0,1.5367061E0,
     +     1.5635712E0,1.5906454E0,1.6179680E0,1.6455802E0,1.6735255E0,
     +     1.7018503E0,1.7306045E0,1.7598422E0,1.7896223E0,1.8200099E0,
     +     1.8510770E0,1.8829044E0/
      DATA (V(I),I=46,60)/1.9155830E0,1.9492166E0,1.9839239E0,
     +     2.0198430E0,2.0571356E0,2.0959930E0,2.1366450E0,2.1793713E0,
     +     2.2245175E0,2.2725185E0,2.3239338E0,2.3795007E0,2.4402218E0,
     +     2.5075117E0,2.5834658E0/
      DATA (V(I),I=61,65)/2.6713916E0,2.7769943E0,2.7769943E0,
     +     2.7769943E0,2.7769943/
      DATA (W(I),I=1,20)/0.10405134E-04,0.13956560E-04,0.16473259E-04,
     +     0.18501623E-04,0.20238931E-04,0.21780983E-04,0.23182241E-04,
     +     0.24476931E-04,0.25688121E-04,0.26832186E-04,0.27921226E-04,
     +     0.28964480E-04,0.29969191E-04,0.30941168E-04,0.31885160E-04,
     +     0.32805121E-04,0.33704388E-04,0.34585827E-04,0.35451919E-04,
     +     0.36304851E-04/
      DATA (W(I),I=21,40)/0.37146564E-04,0.37978808E-04,0.38803170E-04,
     +     0.39621114E-04,0.40433997E-04,0.41243096E-04,0.42049621E-04,
     +     0.42854734E-04,0.43659562E-04,0.44465208E-04,0.45272764E-04,
     +     0.46083321E-04,0.46897980E-04,0.47717864E-04,0.48544128E-04,
     +     0.49377973E-04,0.50220656E-04,0.51073504E-04,0.51937936E-04,
     +     0.52815471E-04/
      DATA (W(I),I=41,60)/0.53707761E-04,0.54616606E-04,0.55543990E-04,
     +     0.56492112E-04,0.57463436E-04,0.58460740E-04,0.59487185E-04,
     +     0.60546402E-04,0.61642600E-04,0.62780711E-04,0.63966581E-04,
     +     0.65207221E-04,0.66511165E-04,0.67888959E-04,0.69353880E-04,
     +     0.70922996E-04,0.72618816E-04,0.74471933E-04,0.76525519E-04,
     +     0.78843526E-04/
      DATA (W(I),I=61,65)/0.81526890E-04,0.84749727E-04,0.84749727E-04,
     +     0.84749727E-04,0.84749727E-04/
      DATA M(1),M(2),M(3),M(4),M(5),M(6),M(7),M(8),M(9),M(10),M(11),
     +     M(12),M(13),M(14),M(15),M(16),M(17)/30788,23052,2053,19346,
     +     10646,19427,23975,19049,10949,19693,29746,26748,2796,23890,
     +     29168,31924,16499/
      DATA M1,M2,I1,J1/32767,256,5,17/
      DATA P5,ONE/0.5E0,1.0E0/
C
C FAST PART...
C
C
C***FIRST EXECUTABLE STATEMENT  RANDN
      IF (JD.NE.0) THEN
C  FILL
          MDIG = I1MACH(8) + 1
C
C  MODIFICATION SO SAME NUMBERS WILL BE GENERATED ON ALL MACHINES
C  WITH I1MACH(8) AT LEAST 31
C
          MDIG = MIN(MDIG,32)
C
C  BE SURE THAT MDIG AT LEAST 16...
          IF (MDIG.LT.16) CALL XERROR('RANDN--MDIG LESS THAN 16',23,1,2)
C
          M1 = 2** (MDIG-2) + (2** (MDIG-2)-1)
          M2 = 2** (MDIG/2)
          JSEED = MIN(ABS(JD),M1)
          IF (MOD(JSEED,2).EQ.0) JSEED = JSEED - 1
          K0 = MOD(9069,M2)
          K1 = 9069/M2
          J0 = MOD(JSEED,M2)
          J1 = JSEED/M2
          DO 10 I = 1,17
              JSEED = J0*K0
              J1 = MOD(JSEED/M2+J0*K1+J1*K0,M2/2)
              J0 = MOD(JSEED,M2)
              M(I) = J0 + M2*J1
   10     CONTINUE
          J1 = 17
          I1 = 5
          RMAX = ONE/REAL(M1)
C  SEED UNIFORM (0,1] GENERATOR.  (JUST A DUMMY CALL)
          RANDN = RANDU(JD)
          DO 20 I = 1,65
              W(I) = RMAX*V(I)
   20     CONTINUE
      END IF

      I = M(I1) - M(J1)
      IF (I.LT.0) I = I + M1
      M(J1) = I
      I1 = I1 - 1
      IF (I1.EQ.0) I1 = 17
      J1 = J1 - 1
      IF (J1.EQ.0) J1 = 17
      J = MOD(I,64) + 1
      RANDN = I*W(J+1)
      IF (((I/M2)/2)*2.EQ. (I/M2)) RANDN = -RANDN
      IF (ABS(RANDN).GT.V(J)) THEN
C  SLOW PART; AA IS A*F(0)
          X = (ABS(RANDN)-V(J))/ (V(J+1)-V(J))
          Y = RANDU(0)
          S = X + Y
          IF (S.LE.C2) THEN
              IF (S.LE.C1) THEN
                  RETURN
              ELSE IF (Y.LE.C-AA*EXP(-P5 * (B-B*X)**2)) THEN
                  IF (EXP(-P5*V(J+1)**2)+Y*PC/V(J+1).GT.
     +                EXP(-P5*RANDN**2)) THEN
   30                 CONTINUE
C TAIL PART; 3.855849 IS .5*XN**2
                      S = XN - LOG(RANDU(0))/XN
                      IF (3.855849E0+LOG(RANDU(0))-XN*S.GT.
     +                    -P5*S**2) GO TO 30
                      RANDN = SIGN(S,RANDN)
                  END IF
                  RETURN
              ELSE
              END IF
          END IF
          RANDN = SIGN(B-B*X,RANDN)
      END IF
      END
*RANDU
      REAL FUNCTION RANDU(JD)
C***BEGIN PROLOGUE  RANDU  (ORIGINALLY UNI)
C***DATE WRITTEN   810915
C***REVISION DATE  900315
C***CATEGORY NO.  L6A21
C***KEYWORDS  RANDOM NUMBERS, UNIFORM RANDOM NUMBERS
C***AUTHOR    BLUE, JAMES
C             KAHANER, DAVID
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST
C
C             MARSAGLIA, GEORGE
C             COMPUTER SCIENCE DEPT., WASH STATE UNIV
C
C             MODIFIED BY -
C             DONALDSON, JANET
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST
C
C***PURPOSE  THIS ROUTINE GENERATES QUASI UNIFORM RANDOM NUMBERS ON
C             (0,1] AND CAN BE USED ON ANY COMPUTER WITH WHICH ALLOWS
C             INTEGERS AT LEAST AS LARGE AS 32767.
C***DESCRIPTION
C
C       THIS ROUTINE GENERATES QUASI UNIFORM RANDOM NUMBERS ON THE
C       INTERVAL (0,1].  IT CAN BE USED WITH ANY COMPUTER WHICH ALLOWS
C       INTEGERS AT LEAST AS LARGE AS 32767.
C
C
C   USE
C       FIRST TIME....
C                   Z = RANDU(JD)
C                     HERE JD IS ANY  N O N - Z E R O  INTEGER.
C                     THIS CAUSES INITIALIZATION OF THE PROGRAM
C                     AND THE FIRST RANDOM NUMBER TO BE RETURNED AS Z.
C       SUBSEQUENT TIMES...
C                   Z = RANDU(0)
C                     CAUSES THE NEXT RANDOM NUMBER TO BE RETURNED AS Z.
C
C
C===================================================================
C   NOTE: USERS WHO WISH TO TRANSPORT THIS PROGRAM FROM ONE COMPUTER
C         TO ANOTHER SHOULD READ THE FOLLOWING INFORMATION:
C
C   MACHINE DEPENDENCIES...
C      MDIG = A LOWER BOUND ON THE NUMBER OF BINARY DIGITS AVAILABLE
C              FOR REPRESENTING INTEGERS, INCLUDING THE SIGN BIT.
C              THIS VALUE MUST BE AT LEAST 16, BUT MAY BE INCREASED
C              IN LINE WITH REMARK A BELOW.
C
C   REMARKS...
C     A. THIS PROGRAM CAN BE USED IN TWO WAYS:
C        (1) TO OBTAIN REPEATABLE RESULTS ON DIFFERENT COMPUTERS,
C            SET 'MDIG' TO THE SMALLEST OF ITS VALUES ON EACH, OR,
C        (2) TO ALLOW THE LONGEST SEQUENCE OF RANDOM NUMBERS TO BE
C            GENERATED WITHOUT CYCLING (REPEATING) SET 'MDIG' TO THE
C            LARGEST POSSIBLE VALUE.
C     B. THE SEQUENCE OF NUMBERS GENERATED DEPENDS ON THE INITIAL
C          INPUT 'JD' AS WELL AS THE VALUE OF 'MDIG'.
C          IF MDIG=16 ONE SHOULD FIND THAT
C            THE FIRST EVALUATION
C              Z=RANDU(305) GIVES Z=.027832881...
C            THE SECOND EVALUATION
C              Z=RANDU(0) GIVES   Z=.56102176...
C            THE THIRD EVALUATION
C              Z=RANDU(0) GIVES   Z=.41456343...
C            THE THOUSANDTH EVALUATION
C              Z=RANDU(0) GIVES   Z=.19797357...
C
C***REFERENCES  MARSAGLIA G., "COMMENTS ON THE PERFECT UNIFORM RANDOM
C                 NUMBER GENERATOR", UNPUBLISHED NOTES, WASH S. U.
C***ROUTINES CALLED  I1MACH,XERROR
C***END PROLOGUE  RANDU
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   JD
C
C  LOCAL SCALARS
      REAL
     +   ONE,ZERO
      INTEGER
     +   I,J,J0,J1,JSEED,K,K0,K1,M1,M2,MDIG
C
C  LOCAL ARRAYS
      INTEGER
     +   M(17)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   I1MACH
      EXTERNAL I1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERROR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MIN,MOD,REAL
C
C  SAVE STATEMENT
      SAVE I,J,M,M1,M2
C
C
      DATA M(1),M(2),M(3),M(4),M(5),M(6),M(7),M(8),M(9),M(10),M(11),
     +     M(12),M(13),M(14),M(15),M(16),M(17)/30788,23052,2053,19346,
     +     10646,19427,23975,19049,10949,19693,29746,26748,2796,23890,
     +     29168,31924,16499/
      DATA M1,M2,I,J/32767,256,5,17/
      DATA ZERO,ONE /0.0E0,1.0E0/
C
C***FIRST EXECUTABLE STATEMENT  RANDU
      IF (JD.NE.0) THEN
C  FILL
          MDIG = I1MACH(8) + 1
C
C  MODIFICATION SO SAME NUMBERS WILL BE GENERATED ON ALL MACHINES
C  WITH I1MACH(8) AT LEAST 31
C
          MDIG = MIN(MDIG,32)
C
C  BE SURE THAT MDIG AT LEAST 16...
          IF (MDIG.LT.16) CALL XERROR('RANDU--MDIG LESS THAN 16',22,1,2)
          M1 = 2** (MDIG-2) + (2** (MDIG-2)-1)
          M2 = 2** (MDIG/2)
          JSEED = MIN(ABS(JD),M1)
          IF (MOD(JSEED,2).EQ.0) JSEED = JSEED - 1
          K0 = MOD(9069,M2)
          K1 = 9069/M2
          J0 = MOD(JSEED,M2)
          J1 = JSEED/M2
          DO 10 I = 1,17
              JSEED = J0*K0
              J1 = MOD(JSEED/M2+J0*K1+J1*K0,M2/2)
              J0 = MOD(JSEED,M2)
              M(I) = J0 + M2*J1
   10     CONTINUE
          I = 5
          J = 17
      END IF
C  BEGIN MAIN LOOP HERE
      K = M(I) - M(J)
      IF (K.LT.0) K = K + M1
      M(J) = K
      I = I - 1
      IF (I.EQ.0) I = 17
      J = J - 1
      IF (J.EQ.0) J = 17
      RANDU = REAL(K)/REAL(M1)
C
C  MODIFICATION SO RANDOM NUMBERS IN (0,1] RATHER THAN [0,1)
C
      IF (RANDU.EQ.ZERO) RANDU = ONE
      END
*RANKO
      SUBROUTINE RANKO(N, Y, H, R, T)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     VERSION  45.0    RANKO    3/ 6/70
C     *****
C     PUTS RANK OF N X"S IN VECTOR R. VECTOR H IS USED FOR STORAGE.
C     X,H AND R MUST BE DIMENSIONED N OR GREATER.
C     STORES CORRECTION FOR TIES IN T = SUM(T-1)*T*(T+1).
C        N.B.  T IS 12 TIMES VALUE COMPUTED BY ORIGINAL OMNITAB ROUTINE.
C     T=0  MEANS NO TIES.
C     WRITTEN BY DAVID HOGBEN, SEL, NBS.   4/9/69.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   T
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   R(N),Y(N)
      INTEGER
     +   H(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IJ,J,K,K2
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SRTIR,SRTRI
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER H(N)
C        THE INDICES TO THE HIERARCHY OF R
C     INTEGER I
C        INDEX VARIABLE
C     INTEGER IJ
C        INDEX VARIABLE BASED ON I-J
C     INTEGER J
C        INDEX VARIABLE
C     INTEGER K
C        INDEX VARIABLE
C     INTEGER K2
C          INDEX VARIABLE
C     INTEGER N
C        NUMBER OF OBSERVATIONS
C     REAL R(N)
C        FINAL VECTOR CONTAINING RANK
C     REAL T
C        12 TIMES THE OMNITAB CORRECTION FOR TIES
C             T = SUM(T-1)*T*(T+1)
C             T = 0 MEANS NO TIES
C     REAL Y(N)
C        VECTOR TO BE RANKED
C
C
C     MOVE Y TO R AND PUT I IN H
C
      DO 10 I=1,N
         H(I) = I
         R(I) = Y(I)
   10 CONTINUE
C
C     SORT Y IN R, CARRY ALONG I IN H TO OBTAIN HIERARCHY IN H.
C
      CALL SRTIR(H, N, R)
C
C     REPLACE R(I) BY I*.
C     LET K BE SUCH THAT R(I)=R(I-J+1),J=1,K. THEN I* = I-(K-1)/2.
C
      K = 1
      T = 0
      DO 40 I=2,N
         IF (R(I).EQ.R(I-1)) THEN
            K = K + 1
         ELSE
            DO 30 J=1,K
               IJ = I - J
               R(IJ) = (I-1) - (K-1)/2.0E0
   30       CONTINUE
            T = T + (K-1)*K*(K+1)
            K = 1
         END IF
   40 CONTINUE
      T = T + (K-1)*K*(K+1)
      DO 50 I=1,K
         K2 = N + 1 - I
         R(K2) = N - (K-1)/2.0E0
   50 CONTINUE
C
C     SORT H CARRY ALONG R TO OBTAIN RANKS IN R
C
      CALL SRTRI(R, N, H)
      RETURN
      END
*REALTR
      SUBROUTINE REALTR(A, B, N, ISN)
C  IF ISN=1, THIS SUBROUTINE COMPLETES THE FOURIER TRANSFORM
C    OF 2*N DATA VALUES, WHERE THE ORIGINAL DATA VALUES ARE
C    STORED ALTERNATELY IN ARRAYS A AND B, AND ARE FIRST
C    TRANSFORMED BY A COMPLEX FOURIER TRANSFORM OF DIMENSION N.
C    THE COSINE COEFFICIENTS ARE IN A(1),A(2),...A(N+1) AND
C    THE SINE COEFFICIENTS ARE IN B(1),B(2),...B(N+1).
C    A TYPICAL CALLING SEQUENCE IS
C      CALL FFT(A,B,N,N,N,1)
C      CALL REALTR(A,B,N,1)
C    THE RESULTS SHOULD BE MULTIPLIED BY 0.5E0/N TO GIVE THE
C    USUAL SCALING OF COEFFICIENTS.
C  IFISN-1, THE INVERSE TRANSFORMATION IS DONE, THE FIRST STEP
C    IN EVALUATING A REAL FOURIER SERIES.
C    A TYPICAL CALLING SEQUENCE IS
C      CALL REALTRA(A,B,N,-1)
C      CALL FFT(A,B,N,N,N,-1)
C    THE RESULTS SHOULD BE MULTIPLIED BY 0.5E0 TO GIVE THE USUAL
C    SCALING, AND THE TIME DOMAIN RESULTS ALTERNATE IN ARRAYS A
C    AND B, I.E. A(1),B(1),A(2),B(2),...A(N),B(N).
C  THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX
C    ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO
C    GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO
C    PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY
C    VALUES, E.G.
C      CALL FFT(A,A(2),N,N,N,2)
C      CALL REALTR(A,A(2),N,2)
C    IN THIS CASE, THE COSINE AND SINE COEFFICIENTS ALTERNATE IN A.
C  BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISN,N
C
C  ARRAY ARGUMENTS
      REAL
     +   A(1),B(1)
C
C  LOCAL SCALARS
      REAL
     +   AA,AB,BA,BB,CD,CN,IM,RE,SD,SN
      INTEGER
     +   INC,J,K,NH,NK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ATAN,IABS,SIN
C
C
C
      INC = IABS(ISN)
      NK = N*INC + 2
      NH = NK/2
      SD = 2.0E0*ATAN(1.0E0)/N
      CD = 2.0E0*SIN(SD)**2
      SD = SIN(SD+SD)
      SN = 0.0E0
      IF (ISN.LT.0) GO TO 30
      CN = 1.0E0
      A(NK-1) = A(1)
      B(NK-1) = B(1)
   10 DO 20 J=1,NH,INC
         K = NK - J
         AA = A(J) + A(K)
         AB = A(J) - A(K)
         BA = B(J) + B(K)
         BB = B(J) - B(K)
         RE = CN*BA + SN*AB
         IM = SN*BA - CN*AB
         B(K) = IM - BB
         B(J) = IM + BB
         A(K) = AA - RE
         A(J) = AA + RE
         AA = CN - (CD*CN+SD*SN)
         SN = (SD*CN-CD*SN) + SN
         CN = 0.5E0/(AA**2+SN**2) + 0.5E0
         SN = CN*SN
         CN = CN*AA
   20 CONTINUE
      RETURN
   30 CN = -1.0E0
      SD = -SD
      GO TO 10
      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
      REAL
     +   ABSTOL,RELTOL
      INTEGER
     +   N,NFAIL
C
C  ARRAY ARGUMENTS
      REAL
     +   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     REAL 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     REAL RELTOL
C        THE RELATIVE TOLERANCE USED IN THE COMPARISON.
C     REAL V(N), W(N)
C        THE VALUES BEING COMPARED.
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.0E0).OR.(W(I).EQ.0.0E0)).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
*RELDST
      REAL 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
      REAL
     +   D(P),X(P),X0(P)
C
C  LOCAL SCALARS
      REAL
     +   EMAX,T,XMAX,ZERO
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
      DATA ZERO/0.0E0/
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
*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
      REAL
     +   D(NRESTS*NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,I1,I2,J
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
*RMDCON
      REAL 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
      REAL
     +   BIG,ETA,MACHEP,ONE001,PT999
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
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
C
      DATA ONE001/1.001E0/, PT999/0.999E0/
C
      BIG = R1MACH(2)
      ETA = R1MACH(1)
      MACHEP = R1MACH(4)
C
C-------------------------------  BODY  --------------------------------
C
      GO TO (10, 20, 30, 40, 50, 60), K
C
 10   RMDCON = ETA
      GO TO 999
C
 20   RMDCON = SQRT(ONE001*ETA)
      GO TO 999
C
 30   RMDCON = MACHEP
      GO TO 999
C
 40   RMDCON = SQRT(PT999*MACHEP)
      GO TO 999
C
 50   RMDCON = SQRT(PT999*BIG)
      GO TO 999
C
 60   RMDCON = BIG
C
 999  RETURN
C  ***  LAST CARD OF RMDCON FOLLOWS  ***
      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
      REAL
     +   J(NN,P),RD(P),X(P),Y(P),Z(P)
      INTEGER
     +   IPIVOT(P)
C
C  LOCAL SCALARS
      REAL
     +   ZK
      INTEGER
     +   I,IM1,K,KM1
C
C  EXTERNAL FUNCTIONS
      REAL
     +   DOTPRD
      EXTERNAL DOTPRD
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
*S88FMT
      SUBROUTINE S88FMT( N, W, IFMT )
C
C     LATEST REVISION  -  OCTOBER 3, 1983  (JRD)
C
C  S88FMT  REPLACES IFMT(1), ... , IFMT(N) WITH
C  THE CHARACTERS CORRESPONDING TO THE N LEAST SIGNIFICANT
C  DIGITS OF W.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER N,W
C
C  ARRAY ARGUMENTS
      CHARACTER IFMT(N)*4
C
C  LOCAL SCALARS
      INTEGER IDIGIT,NT,WT
C
C  LOCAL ARRAYS
      CHARACTER DIGITS(10)*4
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C
      DATA DIGITS( 1) / '0' /
      DATA DIGITS( 2) / '1' /
      DATA DIGITS( 3) / '2' /
      DATA DIGITS( 4) / '3' /
      DATA DIGITS( 5) / '4' /
      DATA DIGITS( 6) / '5' /
      DATA DIGITS( 7) / '6' /
      DATA DIGITS( 8) / '7' /
      DATA DIGITS( 9) / '8' /
      DATA DIGITS(10) / '9' /
C
      NT = N
      WT = W
C
 10   IF (NT .LE. 0) RETURN
        IDIGIT = MOD( WT, 10 )
        IFMT(NT) = DIGITS(IDIGIT+1)
        WT = WT/10
        NT = NT - 1
        GO TO 10
C
      END
*SAMPLE
      SUBROUTINE SAMPLE (Y, N, NS, YS, NYS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE SAMPLES EVERY KTH OBSERVATION FROM THE INPUT
C     SERIES Y, STORING THE SAMPLED SERIES IN YS.
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
     +   N,NS,NYS
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      LOGICAL
     +   ERR01,ERR02,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LN(8)*1,LNS(8)*1,LONE(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,IPRINT,SMPLY
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02
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 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     CHARACTER*1 LN(8), LNS(8), LONE(8)
C        THE ARRAY CONTAINING THE NAME OF THE VARIABLE N AND NS.
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 NS
C        THE SAMPLING RATE.
C     INTEGER NYS
C        THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YS(N)
C        THE VECTOR IN WHICH THE SAMPLED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'S',       'A',       'M',       'P',       'L',       'E'/
      DATA
     +  LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8)
     + /  'N',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LNS(1), LNS(2), LNS(3), LNS(4), LNS(5), LNS(6), LNS(7), LNS(8)
     + /  'N',   'S',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7),
     +  LONE(8)
     + /  'O',   'N',   'E',   ' ',   ' ',   ' ',   ' ',   ' '/
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 EISII(NMSUB, LNS, NS, 1, N, 1, HEAD, ERR02, LONE, LN)
C
      IF (ERR01 .OR. ERR02) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
      CALL SMPLY (Y, N, NS, YS, NYS)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   38H       CALL SAMPLE (Y, N, NS, YS, NYS))
      END
*SETERR
      SUBROUTINE SETERR(MESSG,NMESSG,NERR,IOPT)
C
C  SETERR SETS LERROR = NERR, OPTIONALLY PRINTS THE MESSAGE AND DUMPS
C  ACCORDING TO THE FOLLOWING RULES...
C
C    IF IOPT = 1 AND RECOVERING      - JUST REMEMBER THE ERROR.
C    IF IOPT = 1 AND NOT RECOVERING  - PRINT AND STOP.
C    IF IOPT = 2                     - PRINT, DUMP AND STOP.
C
C  INPUT
C
C    MESSG  - THE ERROR MESSAGE.
C    NMESSG - THE LENGTH OF THE MESSAGE, IN CHARACTERS.
C    NERR   - THE ERROR NUMBER. MUST HAVE NERR NON-ZERO.
C    IOPT   - THE OPTION. MUST HAVE IOPT=1 OR 2.
C
C  ERROR STATES -
C
C    1 - MESSAGE LENGTH NOT POSITIVE.
C    2 - CANNOT HAVE NERR=0.
C    3 - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.
C    4 - BAD VALUE FOR IOPT.
C
C  ONLY THE FIRST 72 CHARACTERS OF THE MESSAGE ARE PRINTED.
C
C  THE ERROR HANDLER CALLS A SUBROUTINE NAMED FDUMP TO PRODUCE A
C  SYMBOLIC DUMP. TO COMPLETE THE PACKAGE, A DUMMY VERSION OF FDUMP
C  IS SUPPLIED, BUT IT SHOULD BE REPLACED BY A LOCALLY WRITTEN VERSION
C  WHICH AT LEAST GIVES A TRACE-BACK.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER IOPT,NERR,NMESSG
C
C  ARRAY ARGUMENTS
      CHARACTER MESSG(NMESSG)*4
C
C  LOCAL SCALARS
      INTEGER ITEMP,IWUNIT,NW
C
C  EXTERNAL FUNCTIONS
      INTEGER I1MACH,I8SAVE
      EXTERNAL I1MACH,I8SAVE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL E9RINT,EPRINT,FDUMP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C
C  THE UNIT FOR ERROR MESSAGES.
C
      IWUNIT=I1MACH(4)
C
      IF (NMESSG.GE.1) GO TO 10
C
C  A MESSAGE OF NON-POSITIVE LENGTH IS FATAL.
C
        WRITE(IWUNIT,9000)
 9000   FORMAT('1ERROR    1 IN SETERR - MESSAGE LENGTH NOT POSITIVE.')
        GO TO 60
C
C  NW IS THE NUMBER OF WORDS THE MESSAGE OCCUPIES.
C
 10   NW=(MIN(NMESSG,72)-1)/I1MACH(6)+1
C
      IF (NERR.NE.0) GO TO 20
C
C  CANNOT TURN THE ERROR STATE OFF USING SETERR.
C
        WRITE(IWUNIT,9001)
 9001   FORMAT('1ERROR    2 IN SETERR - CANNOT HAVE NERR=0'//
     1         ' THE CURRENT ERROR MESSAGE FOLLOWS'///)
        CALL E9RINT(MESSG,NW,NERR,.TRUE.)
        ITEMP=I8SAVE(1,1,.TRUE.)
        GO TO 50
C
C  SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR.
C
 20   IF (I8SAVE(1,NERR,.TRUE.).EQ.0) GO TO 30
C
        WRITE(IWUNIT,9002)
 9002   FORMAT('1ERROR    3 IN SETERR -',
     1         ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'//
     2         ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///)
        CALL EPRINT
        CALL E9RINT(MESSG,NW,NERR,.TRUE.)
        GO TO 50
C
C  SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY.
C
 30   CALL E9RINT(MESSG,NW,NERR,.TRUE.)
C
      IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40
C
C  MUST HAVE IOPT = 1 OR 2.
C
        WRITE(IWUNIT,9003)
 9003   FORMAT('1ERROR    4 IN SETERR - BAD VALUE FOR IOPT'//
     1         ' THE CURRENT ERROR MESSAGE FOLLOWS'///)
        GO TO 50
C
C  TEST FOR RECOVERY.
C
 40   IF (IOPT.EQ.2) GO TO 50
C
      IF (I8SAVE(2,0,.FALSE.).EQ.1) RETURN
C
      CALL EPRINT
      STOP
C
 50   CALL EPRINT
 60   CALL FDUMP
      STOP
C
      END
*SETESL
      SUBROUTINE SETESL(N, NDIV, NFFT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE SMALLEST VALUE OF NFFT WHICH
C     EQUALS OR EXCEEDS N + 2, SUCH THAT NFFT - 2 IS
C     1. DIVISIBLE BY NDIV,
C     2. HAS NO MORE THAN 11 PRIME FACTORS,
C     3. HAS NO PRIME FACTOR GREATER THAN 23, AND
C     4. THE PRODUCT OF THE SQUARE FREE PRIME FACTORS OF
C        (NFFT-2)/NDIV DO NOT EXCEED 210 IF NDIV = 2, AND
C                                    105 IF NDIV = 4.
C     THE VALUE OF NFFT THUS MEET THE REQUIREMENTS OF
C     THE EXTENDED LENGTH OF THE SERIES REQUIRED FOR ANY ROUTINE
C     USING THE SINGLETON FFT PROVIDING THE PROPER VALUE OF NDIV
C     IS CHOSEN.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   N,NDIV,NFFT
C
C  LOCAL SCALARS
      INTEGER
     +   I,NPF,NSFP
C
C  LOCAL ARRAYS
      INTEGER
     +   IPF(50),IPFEXP(50)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FACTOR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C       AN INDEX VARIABLE.
C     INTEGER IPF(50), IPFEXP(50)
C        THE VECTORS OF PRIME FACTORS OF NFFT AND THEIR EXPONENTS,
C        RESPECTIVELY, WHERE THE LENGTH OF THESE VECTORS IS
C        SUFFICIENT TO ACCOMODATE THE PRIME FACTORS OF AN INTEGER
C        UP TO 2 ** 128 (APPROXIMATELY 10 ** 40).
C     INTEGER N
C        THE NUMBER UPON WHICH NFFT IS BASED.
C     INTEGER NDIV
C        A REQUIRED FACTOR OF NFFT - 2.
C     INTEGER NFFT
C        THE RETURNED VALUE WHICH MEETS THE ABOVE DESCRIPTION.
C     INTEGER NPF
C        THE NUMBER OF PRIME FACTORS IN NFFT.
C     INTEGER NSFP
C        THE PRODUCT OF THE NON SQUARE FACTORS.
C
      NFFT = N
      IF (NFFT.LE.0) RETURN
      IF (MOD(NFFT, NDIV) .NE. 0) NFFT = NFFT + NDIV - MOD(NFFT, NDIV)
      NFFT = NFFT - NDIV
   20 NFFT = NFFT + NDIV
      CALL FACTOR(NFFT/NDIV, NPF, IPF, IPFEXP)
      IF ((NPF.GE.11) .OR. (IPF(NPF).GT.23)) GO TO 20
      NSFP = 1
      IF (NDIV.EQ.4) NSFP = 2
      DO 30 I = 1, NPF
         IF (MOD(IPFEXP(I), 2).EQ.1) NSFP = NSFP * IPF(I)
   30 CONTINUE
      IF (NSFP .GE. 210) GO TO 20
C
      NFFT = NFFT + 2
C
      RETURN
C
      END
*SETFRQ
      SUBROUTINE SETFRQ (FREQ, NF, NPRT, FMIN, FMAX, H)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE FREQUENCIES AT WHICH THE
C     SPECTRUM IS TO BE ESTIMATED.
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
      REAL
     +   FMAX,FMIN,H
      INTEGER
     +   NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF)
C
C  LOCAL SCALARS
      REAL
     +   DELTAF
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELTAF
C        THE FREQUENCY INCREMENT.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCIES AT WHICH THE
C        SPECTRUM IS TO BE ESTIMATED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     REAL H
C        THE SAMPLING INTERVAL.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES
C        ARE TO BE ESTIMATED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT EQUALS 2 THE FREQUENCY SCALE IS LINEAR, AND IF
C        NPRT EQUALS 3 THE FREQUENCY SCALE IS LOG.
C
      IF (NPRT .EQ. 3) GO TO 20
C
C     COMPUTE FREQUENCY VALUES FOR LINEAR SCALE
C
      FREQ(1) = FMIN
C
      IF (NF .EQ. 1) RETURN
C
      DELTAF = (FMAX - FMIN) / (H * (NF - 1))
      DO 10 I = 2, NF
         FREQ(I) = FREQ(I-1) + DELTAF
   10 CONTINUE
C
      FREQ(NF) = FMAX
      RETURN
C
   20 CONTINUE
C
C     COMPUTE FREQUENCY VALUES FOR LOG SCALE
C
      DELTAF = (LOG10(FMAX) - LOG10(FMIN)) / (H * (NF - 1))
C
      FREQ(1) = FMIN
C
      IF (NF .EQ. 1) RETURN
C
      DO 30 I = 2, NF
         FREQ(I) = 10.0E0**(LOG10(FREQ(I-1)) + DELTAF)
   30 CONTINUE
C
      FREQ(NF) = FMAX
C
C
      RETURN
      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
      DO 10 I=1,N
         VECTOR(I) = VALUE
   10 CONTINUE
C
      RETURN
C
      END
*SETLAG
      SUBROUTINE SETLAG (N, LAGMAX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE NUMBER OF AUTOCORRELATIONS TO BE
C     COMPUTED.
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
     +   LAGMAX,N
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER LAGMAX
C        THE NUMBER OF LAGS AT WHICH THE AUTOCOVARIANCES ARE TO BE
C        COMPUTED.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C
      IF (N .GE. 96)                 LAGMAX = MIN(N / 3, 100)
      IF (33 .LE. N .AND. N .LE. 95) LAGMAX = 32
      IF (N .LE. 32)                 LAGMAX = N - 1
      RETURN
      END
*SETRA
      SUBROUTINE SETRA(ARRAY, IM, M, N, VALUE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     SETS THE FIRST N ROWS AND M COLUMNS OF THE ARRAY
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
      REAL
     +   VALUE
      INTEGER
     +   IM,M,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ARRAY(IM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ARRAY(IM,M)
C        ARRAY FOR WHICH ELEMENTS WILL BE SET
C     INTEGER I
C        *
C     INTEGER IM
C        ACTUAL FIRST DIMENSION OF ARRAY IN CALLING PROGRAM
C     INTEGER J
C        *
C     INTEGER M
C        NUMBER OF COLUMNS TO SET
C     INTEGER N
C        NUMBER OF ROWS TO SET
C     REAL VALUE
C        VALUE TO WHICH THE ELEMENTS ARE TO BE SET
C
C
      DO 20 I=1,N
         DO 10 J=1,M
            ARRAY(I,J) = VALUE
   10    CONTINUE
   20 CONTINUE
      RETURN
      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
      REAL
     +   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     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE MATRIX.
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.0E0) GO TO 20
   10    CONTINUE
         NROWU = I
         RETURN
   20 CONTINUE
C
      NROWU = 1
C
      RETURN
      END
*SETRV
      SUBROUTINE SETRV(VECTOR, N, VALUE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE FIRST N ELEMENTS OF VECTOR
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
      REAL
     +   VALUE
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   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     REAL VALUE
C        VALUE TO WHICH THE ELEMENTS ARE TO BE SET
C     REAL VECTOR(N)
C        VECTOR WHOSE FIRST N ELEMENTS ARE TO BE SET.
C
      DO 10 I=1,N
         VECTOR(I) = VALUE
   10 CONTINUE
C
      RETURN
C
      END
*SLFLT
      SUBROUTINE SLFLT (Y, N, K, H, YF, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PERFORMS A SYMMETRIC FILTERING OPERATION
C     ON AN INPUT SERIES Y, RETURNING THE FILTERED SERIES IN YF.
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,N,NYF
C
C  ARRAY ARGUMENTS
      REAL
     +   H(*),Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LH(8)*1,LK(8)*1,LN(8)*1,LONE(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,ERIODD,ERSLF,FLTSL,IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03, ERR04
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     REAL H(K)
C        THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS.
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 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.
C     CHARACTER*1 LH(8), LK(8), LN(8), LONE(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'S',       'L',       'F',       'L',       'T',       ' '/
      DATA
     +  LH(1), LH(2), LH(3), LH(4), LH(5), LH(6), LH(7), LH(8)
     + /  'H',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7),
     +  LONE(8) /'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/
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 EISII(NMSUB, LK, K, 1, N, 1, HEAD, ERR02, LONE, LN)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR03)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10
C
      CALL ERSLF(NMSUB, LH, K, H, HEAD, ERR04)
C
      IF (.NOT. ERR04) GO TO 20
C
   10 CONTINUE
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   20 CONTINUE
C
      CALL FLTSL (Y, N, K, H, YF, NYF)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   39H       CALL SLFLT (Y, N, K, H, YF, NYF))
      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
      REAL
     +   COSMIN,SIZE,WSCALE
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      REAL
     +   A(1),STEP(P),U(P),W(P),WCHMTD(P),Y(P)
C
C  LOCAL SCALARS
      REAL
     +   DENMIN,HALF,ONE,SDOTWM,T,UI,WI,ZERO
      INTEGER
     +   I,J,K
C
C  EXTERNAL FUNCTIONS
      REAL
     +   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     REAL 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     REAL DENMIN, SDOTWM, T, UI, WI
C
C     ***  CONSTANTS  ***
C     REAL HALF, ONE, ZERO
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL DOTPRD, SLVMUL, V2NORM
C     REAL DOTPRD, V2NORM
C
      DATA HALF/0.5E0/, ONE/1.0E0/, ZERO/0.0E0/
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
*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
      REAL
     +   S(1),X(P),Y(P)
C
C  LOCAL SCALARS
      REAL
     +   XI
      INTEGER
     +   I,IM1,J,K
C
C  EXTERNAL FUNCTIONS
      REAL
     +   DOTPRD
      EXTERNAL DOTPRD
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER P
C     REAL 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     REAL XI
C
C  ***  EXTERNAL FUNCTION  ***
C
C     EXTERNAL DOTPRD
C     REAL DOTPRD
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
*SMPLY
      SUBROUTINE SMPLY (Y, N, NS, YS, NYS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE SAMPLES EVERY KTH OBSERVATION FROM THE INPUT
C     SERIES Y, STORING THE SAMPLED SERIES IN YS.
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
     +   N,NS,NYS
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(N),YS(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I,I1
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I, I1
C        INDEXING VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES Y.
C     INTEGER NS
C        THE SAMPLING RATE.
C     INTEGER NYS
C        THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YS.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YS(N)
C        THE VECTOR IN WHICH THE SAMPLED SERIES IS RETURNED.
C
      NYS = 0
      DO 30 I = 1, N, NS
         NYS = NYS + 1
         YS(NYS) = Y(I)
   30 CONTINUE
      I1 = NYS + 1
      DO 40 I = I1, N
         YS(I) = 0.0E0
   40 CONTINUE
C
      RETURN
      END
*SPCCK
      SUBROUTINE SPCCK (SPC, ISORT, NF, SPCMN, SPCMX, NSPC, ISPCER)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE ANALYZES THE ORDINATES FOR THE SPECTRAL SEMI LOG
C     PLOTS PRODUCED BY THE ASPC SERIES OF ROUTINES.  Y AXIS VALUES
C     (YORD) MORE THAN 3 POWERS OF TEN LESS THAN THE NEXT LARGER
C     VALUE ARE CONSIDERED INSIGNIFICANT AND ARE CULLED FROM THE
C     ORDINATES.
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
      REAL
     +   SPCMN,SPCMX
      INTEGER
     +   ISPCER,NF,NSPC
C
C  ARRAY ARGUMENTS
      REAL
     +   SPC(NF)
      INTEGER
     +   ISORT(NF)
C
C  LOCAL SCALARS
      INTEGER
     +   I,K1,K2,LOG1,LOG2
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SRTIR,SRTRI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER ISORT(NF)
C        THE ARRAY IN WHICH THE ORDER PERMUTATION FOR THE SORTED
C        DATA IS STORED.
C     INTEGER ISPCER
C        AN INDICATOR VARIABLE USED TO SUPRESS THE SPECTRAL PLOTS
C        WHEN FEWER THAN 1 VALID SPECTRAL VALUES WERE COMPUTED.
C     INTEGER K1, K2
C        INDEX VARIABLES.
C     INTEGER LOG1, LOG2
C        THE ORDER OF THE SPECTRAL ESTIMATES.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES
C        ARE TO BE ESTIMATED.
C     INTEGER NSPC
C        THE NUMBER OF VALID SPECTRAL ESTIMATES.
C     REAL SPC(NF)
C        THE ARRAY CONTAINING THE SPECTRAL ESTIMATES.
C     REAL SPCMN, SPCMX
C        THE MINIMUM AND MAXIMUM SPECTRAL VALUE TO BE PLOTTED.
C
C     ORDER THE SPECTRAL ESTIMATES FROM SMALLEST TO LARGEST.
C
      DO 10 I = 1, NF
         ISORT(I) = I
   10 CONTINUE
      CALL SRTIR (ISORT, NF, SPC)
C
C     DETERMINE SIGINIFICANT VALUES TO BE PLOTTED.
C
      K1 = NF
      K2 = K1
      IF ((SPC(NF) .LE. 0.0E0) .OR. (NF.EQ.1)) GO TO 30
      LOG1 = LOG10(SPC(NF))
      IF (SPC(NF) .LT. 1.0E0) LOG1 = LOG1 - 1
      DO 20 I = 2, NF
         K2 = K1 - 1
         IF (SPC(K2) .LE. 0.0E0) GO TO 30
         LOG2 = LOG10(SPC(K2))
         IF (SPC(K2) .LT. 1.0E0) LOG2 = LOG2 - 1
         IF (LOG1-LOG2 .GE. 3 .AND. NF-K2 .GE. 5) GO TO 30
         LOG1 = LOG2
         K1 = K2
   20 CONTINUE
C
   30 SPCMN = SPC(K1)
      NSPC = NF + 1 - K1
C
      SPCMX = SPC(NF)
C
      CALL SRTRI (SPC, NF, ISORT)
      ISPCER = 0
      IF (NF-K2 .LE. 0) ISPCER = 1
C
      RETURN
      END
*SPPC
      SUBROUTINE SPPC(YM, X, N, ISYM, ILOG, ISIZE, NOUT, YLB, YUB,
     +  XLB, XUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH USER CONTROL OF PLOT SYMBOLS (LONG CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,N,NOUT
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XMISS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'P',       'P',       'C',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      XMISS = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 1
      MISS = .FALSE.
      LISYM = N
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL SPPC (Y, X, N, ISYM, ILOG,'/
     +  '      +           ISIZE, NOUT, YLB, YUB, XLB, XUB)')
      END
*SPP
      SUBROUTINE SPP(YM, X, N, ISYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH USER CONTROL OF PLOT SYMBOLS (SHORT CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C     THE LABELED COMMON FOR COMMUNICATING ERROR FLAGS TO THE USER
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'P',       'P',       ' ',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      XMISS = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 1
      ISIZE = -1
      NOUT = 0
      MISS = .FALSE.
      LISYM = N
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL SPP (Y, X, N, ISYM)')
      END
*SPPL
      SUBROUTINE SPPL(YM, X, N, ISYM, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH USER CONTROL OF PLOT SYMBOLS (LOG OPTION).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'P',       'P',       'L',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      XMISS = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 1
      ISIZE = -1
      NOUT = 0
      MISS = .FALSE.
      LISYM = N
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL SPPL (Y, X, N, ISYM, ILOG)')
      END
*SPPLTC
      SUBROUTINE SPPLTC (XAXIS, YAXIS, ISYM, NPTS, XPLTMN, XPLTMX, BW,
     +   CILOW, CIMID, CIUP, LPCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES CONFIDENCE INTERVAL AND BANDWIDTH
C     CO-ORDINATES FOR THE SPECTRUM PLOTS.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   BW,CILOW,CIMID,CIUP,XPLTMN,XPLTMX
      INTEGER
     +   LPCV,NPTS
C
C  ARRAY ARGUMENTS
      REAL
     +   XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL BW
C       THE BANDWIDTH.
C     REAL CILOW, CIMID, CIUP
C        THE Y CORDNATES FOR THE LOWER  MID AND UPPER CONFIDENCE
C        INTERVAL POINTS.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR THE PLOTS.
C     INTEGER NPTS
C        THE NUMBER OF CO-ORDINATES TO BE PLOTTED.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C
      IF (XPLTMX - XPLTMN .GE. BW) GO TO 10
C
      XPLTMX = MAX(XPLTMX + (BW - XPLTMX + XPLTMN) / 2.0E0, 0.5E0)
      XPLTMN = XPLTMX - BW
C
   10 CONTINUE
C
      NPTS = NPTS + 1
C
      XAXIS(NPTS) = XPLTMX - 0.5E0 * BW
      YAXIS(NPTS) = CIUP
      ISYM(NPTS) = 7
C
      NPTS = NPTS + 1
C
      XAXIS(NPTS) = XPLTMX - 0.5E0 * BW
      YAXIS(NPTS) = CIMID
      ISYM(NPTS) = 3
C
      NPTS = NPTS + 1
C
      XAXIS(NPTS) = XPLTMX - 0.5E0 * BW
      YAXIS(NPTS) = CILOW
      ISYM(NPTS) = 13
C
      NPTS = NPTS + 1
C
      XAXIS(NPTS) = XPLTMX - BW
      YAXIS(NPTS)  = CIMID
      ISYM(NPTS) = 6
C
      NPTS = NPTS + 1
C
      XAXIS(NPTS) = XPLTMX
      YAXIS(NPTS)  = CIMID
      ISYM(NPTS) = 27
C
      RETURN
      END
*SPPLTD
      SUBROUTINE SPPLTD (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX,
     +   CILOW, CIMID, CIUP, YMAX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS VARIOUS Y AXIS LIMITS FOR DECIBLE
C     SPECTRUM PLOTS.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   ALOW,AUP,CILOW,CIMID,CIUP,SPCMN,SPCMX,YMAX,YPLTMN,YPLTMX
C
C  LOCAL SCALARS
      REAL
     +   RNGMN,YMIN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG10
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALOW, AUP
C        FACTORS USED TO COMPUTE THE CONFIDENCE INTERVALS.
C     REAL CILOW, CIMID, CIUP
C        THE Y CORDNATES FOR THE LOWER  MID AND UPPER CONFIDENCE
C        INTERVAL POINTS.
C     REAL RNGMN
C        THE MINIMUM Y AXIS RANGE FOR THE PLOT.
C     REAL SPCMN, SPCMX
C        THE MINIMUM AND MAXIMUM SPECTRAL VALUE TO BE PLOTTED.
C     REAL YMAX, YMIN
C        THE MAXIMUM AND MINIMUM ACTUAL SPECTRAL VALUE
C        (IN DECIBELS) TO BE PLOTTED.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET CO-ORDINATES FOR DECIBLE PLOTS
C
      YMAX = 10.0E0 * LOG10(SPCMX)
      YMIN = 10.0E0 * LOG10(SPCMN) - YMAX
C
      YPLTMX = 0.0E0
      RNGMN = 20.0E0 * (LOG10(AUP) - LOG10(ALOW))
      IF (ABS(YMIN) .LT. RNGMN) YPLTMX = (RNGMN + YMIN) * 0.5E0
      YPLTMN = YMIN - YPLTMX
      CIUP = YPLTMX
      CIMID = CIUP - 10.0E0 * LOG10(AUP)
      CILOW = CIMID + 10.0E0 * LOG10(ALOW)
C
      RETURN
      END
*SPPLTL
      SUBROUTINE SPPLTL (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX,
     +   CILOW, CIMID, CIUP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS VARIOUS Y AXIS LIMITS FOR DECIBLE
C     SPECTRUM PLOTS.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   ALOW,AUP,CILOW,CIMID,CIUP,SPCMN,SPCMX,YPLTMN,YPLTMX
C
C  LOCAL SCALARS
      REAL
     +   RNGMN,YMAX,YMIN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALOW, AUP
C        FACTORS USED TO COMPUTE THE CONFIDENCE INTERVALS.
C     REAL CILOW, CIMID, CIUP
C        THE Y CORDNATES FOR THE LOWER  MID AND UPPER CONFIDENCE
C        INTERVAL POINTS.
C     REAL RNGMN
C        THE MINIMUM Y AXIS RANGE FOR THE PLOT.
C     REAL SPCMN, SPCMX
C        THE MINIMUM AND MAXIMUM SPECTRAL VALUE TO BE PLOTTED.
C     REAL YMAX, YMIN
C        THE MAXIMUM AND MINIMUM ACTUAL SPECTRUM VALUE TO BE PLOTTED.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET CO-ORDINATES FOR DECIBLE PLOTS
C
      YMAX = LOG10(SPCMX)
      YMIN = LOG10(SPCMN)
C
      YPLTMX = SPCMX
      YPLTMN = SPCMN
      RNGMN = 2.0E0 * (LOG10(AUP) - LOG10(ALOW))
      IF (YMAX - YMIN .GE. RNGMN) GO TO 10
C
      YPLTMX = 10.0E0 ** (YMAX + (RNGMN - YMAX + YMIN) * 0.5E0)
      YPLTMN = 10.0E0 ** (YMIN - (RNGMN - YMAX + YMIN) * 0.5E0)
C
   10 CIUP = YPLTMX
      CIMID = CIUP / AUP
      CILOW = CIMID * ALOW
C
      RETURN
      END
*SPPMC
      SUBROUTINE SPPMC(YM, YMMISS, X, XMISS, N, ISYM, ILOG, ISIZE, NOUT,
     +   YLB, YUB, XLB, XUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH USER CONTROL OF PLOT SYMBOLS AND WITH MISSING
C     OBSERVATIONS (LONG CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XLB,XMISS,XUB,YLB,YUB
      INTEGER
     +   ILOG,ISIZE,N,NOUT
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(1)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'P',       'P',       'M',       'C',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 1
      MISS = .TRUE.
      LISYM = N
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL SPPMC (Y, YMISS, X, XMISS, N, ISYM, ILOG,'/
     +   '      +            ISIZE, NOUT, YLB, YUB, XLB, XUB)')
      END
*SPPM
      SUBROUTINE SPPM(YM, YMMISS, X, XMISS, N, ISYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH USER CONTROL OF PLOT SYMBOLS AND WITH MISSING
C     OBSERVATIONS (SHORT CALL).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XMISS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(1)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'P',       'P',       'M',       ' ',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 1
      ISIZE = -1
      NOUT = 0
      MISS = .TRUE.
      LISYM = N
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL SPPM (Y, YMISS, X, XMISS, N, ISYM)')
      END
*SPPML
      SUBROUTINE SPPML(YM, YMMISS, X, XMISS, N, ISYM, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE
C     PLOT WITH USER CONTROL OF PLOT SYMBOLS AND WITH MISSING
C     OBSERVATIONS (LOG OPTION).
C
C     WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XMISS
      INTEGER
     +   ILOG,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(*),YM(*),YMMISS(1)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XLB,XUB,YLB,YUB
      INTEGER
     +   IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING.
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NOUT
C        USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS
C        OF THE PLOT ARE TO BE LISTED.
C     REAL X(N)
C        VECTOR OF OBSERVATIONS FOR X COORDINATES
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL XMISS
C        THE MISSING VALUE CODE FOR THE X-AXIS.
C     REAL XUB
C        THE UPPER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(N,1)
C        VECTOR OF OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'P',       'P',       'M',       'L',       ' '/
C
C     COMMENCE BODY OF ROUTINE
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 0.0E0
      XUB = 0.0E0
      ISCHCK = 1
      ISIZE = -1
      NOUT = 0
      MISS = .TRUE.
      LISYM = N
C
      CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG,
     +  YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS,
     +  LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL SPPML (Y, YMISS, X, XMISS, N, ISYM, ILOG)')
      END
*SRTIR
      SUBROUTINE SRTIR(IR, LA, A)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C   FUNCTION     SRTIR  - SORT INTEGER ARRAY IR ON KEY ARRAY A.
C                           IF THE INTEGER ARRAY CONSISTS OF THE
C                           ORDERED SEQUENCE 1, 2, ... LA, THEN
C                           ON COMPLETION IR IS  A PERMUTATION
C                           VECTOR FOR THE SORT OF A.
C   USAGE               - CALL SRTIR (A,LA,IR)
C   PARAMETERS   A(LA)  - ON INPUT, CONTAINS THE ARRAY TO BE SORTED ON
C                         ON OUTPUT, A CONTAINS THE SORTED ARRAY
C                LA     - INPUT VARIABLE CONTAINING THE NUMBER OF
C                           ELEMENTS IN THE ARRAY TO BE SORTED
C                IR(LA) - IF ON INPUT, IR CONTAINS THE INTEGER VALUES
C                           1,2,...,LA.
C                       - THEN ON OUTPUT, IR CONTAINS A RECORD OF THE
C                           PERMUTATIONS MADE ON THE VECTOR A.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LA
C
C  ARRAY ARGUMENTS
      REAL
     +   A(LA)
      INTEGER
     +   IR(LA)
C
C  LOCAL SCALARS
      REAL
     +   R,T,TT
      INTEGER
     +   I,IJ,IT,ITT,J,K,L,M
C
C  LOCAL ARRAYS
      INTEGER
     +   IL(21),IU(21)
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT
C
C
      M = 1
      I = 1
      J = LA
      R = .375E0
   10 IF (I.EQ.J) GO TO 90
      IF (R.GT.0.5898437E0) GO TO 20
      R = R + 3.90625E-2
      GO TO 30
   20 R = R - .21875E0
   30 K = I
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION T
      IJ = I + INT((J-I)*R)
      T = A(IJ)
      IT = IR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (A(I).LE.T) GO TO 40
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
   40 L = J
C                                  IF LAST ELEMENT OF ARRAY IS LESS THAN
C                                  T, INTERCHANGE WITH T
      IF (A(J).GE.T) GO TO 60
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      IR(IJ) = IR(J)
      IR(J) = IT
      IT = IR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (A(I).LE.T) GO TO 60
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      GO TO 60
   50 TT = A(L)
      A(L) = A(K)
      A(K) = TT
      ITT = IR(L)
      IR(L) = IR(K)
      IR(K) = ITT
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN T
   60 L = L - 1
      IF (A(L).GT.T) GO TO 60
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN T
   70 K = K + 1
      IF (A(K).LT.T) GO TO 70
C                                  INTERCHANGE THESE ELEMENTS
      IF (K.LE.L) GO TO 50
C                                  SAVE UPPER AND LOWER SUBSCRIPTS OF
C                                  THE ARRAY YET TO BE SORTED
      IF (L-I.LE.J-K) GO TO 80
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 100
   80 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 100
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
   90 M = M - 1
      IF (M.EQ.0) RETURN
      I = IL(M)
      J = IU(M)
  100 IF (J-I.GE.1) GO TO 30
      IF (I.EQ.1) GO TO 10
      I = I - 1
  110 I = I + 1
      IF (I.EQ.J) GO TO 90
      T = A(I+1)
      IT = IR(I+1)
      IF (A(I).LE.T) GO TO 110
      K = I
  120 A(K+1) = A(K)
      IR(K+1) = IR(K)
      K = K - 1
      IF (T.LT.A(K)) GO TO 120
      A(K+1) = T
      IR(K+1) = IT
      GO TO 110
      END
*SRTIRR
      SUBROUTINE SRTIRR(IR, RR, LA, A)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SORTS THE LENGTH LA ARRAY A, THE LENGTH LA
C     INTEGER ARRAY IR, AND THE LENGTH LA ARRAY RR INTO
C     ASCENDING ORDER, BASED ON THE VALUES IN A.  THE ARRAY
C     A CONSTITUTES THE SORTING KEY.  THE OTHER TWO ARRAYS ARE
C     CARRIED ALONG.  ORDINARILY THE ARRAY IR CONTAINS THE
C     VALUES 1, ..., LA INITIALLY, SO THAT THE THREE ARRAYS CAN
C     LATER BE SORTED AGAIN WITH IR AS THE KEY, IN ORDER TO
C     RESTORE A AND RR TO THEIR ORIGINAL ORDER.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C        (BASED CLOSELY ON THE IMSL CDC LIBRARY 3 ROUTINE VSORTP)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LA
C
C  ARRAY ARGUMENTS
      REAL
     +   A(LA),RR(LA)
      INTEGER
     +   IR(LA)
C
C  LOCAL SCALARS
      REAL
     +   R,RT,RTT,T,TT
      INTEGER
     +   I,IJ,IT,ITT,J,K,L,M
C
C  LOCAL ARRAYS
      INTEGER
     +   IL(21),IU(21)
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL A(LA)
C        INPUT/OUTPUT PARAMETER.  THE KEY ARRAY.
C     INTEGER I
C        *
C     INTEGER IJ
C        *
C     INTEGER IL(21)
C        *
C     INTEGER IR(LA)
C        INPUT/OUTPUT PARAMETER.  THE INTEGER ARRAY CARRIED ALONG
C        IN THE SORT.  INITIALLY IT SHOULD CONTAIN 1, ..., LA.
C        ON EXIT IT CONTAINS THE PERMUTATION VECTOR OF THE SORT.
C        SORTING ON THE PERMUTATION VECTOR WILL RESTORE THE KEY
C        ARRAY A AND THE ARRAY RR TO THEIR ORIGINAL ORDERS.
C     INTEGER IT
C        *
C     INTEGER ITT
C        *
C     INTEGER IU(21)
C        *
C     INTEGER J
C        *
C     INTEGER K
C        *
C     INTEGER L
C        *
C     INTEGER LA
C        INPUT PARAMETER.  THE LENGTH OF THE INPUT/OUTPUT PARAMETERS
C        A, IR, AND RR.
C     INTEGER M
C        *
C     REAL R
C        *
C     REAL RR(LA)
C        INPUT/OUTPUT PARAMETER.  THE ARRAY CARRIED ALONG IN
C        THE SORT.  IT MIGHT BE THE SET OF WEIGHTS FOR A.
C     REAL RT
C        *
C     REAL RTT
C        *
C     REAL T
C        *
C     REAL TT
C
      M = 1
      I = 1
      J = LA
      R = .375E0
   10 IF (I.EQ.J) GO TO 90
      IF (R.GT.0.5898437E0) GO TO 20
      R = R + 3.90625E-2
      GO TO 30
   20 R = R - .21875E0
   30 K = I
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION T
      IJ = I + INT((J-I)*R)
      T = A(IJ)
      IT = IR(IJ)
      RT = RR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (A(I).LE.T) GO TO 40
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      RR(IJ) = RR(I)
      RR(I) = RT
      RT = RR(IJ)
   40 L = J
C                                  IF LAST ELEMENT OF ARRAY IS LESS THAN
C                                  T, INTERCHANGE WITH T
      IF (A(J).GE.T) GO TO 60
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      IR(IJ) = IR(J)
      IR(J) = IT
      IT = IR(IJ)
      RR(IJ) = RR(J)
      RR(J) = RT
      RT = RR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (A(I).LE.T) GO TO 60
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      RR(IJ) = RR(I)
      RR(I) = RT
      RT = RR(IJ)
      GO TO 60
   50 TT = A(L)
      A(L) = A(K)
      A(K) = TT
      ITT = IR(L)
      IR(L) = IR(K)
      IR(K) = ITT
      RTT = RR(L)
      RR(L) = RR(K)
      RR(K) = RTT
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN T
   60 L = L - 1
      IF (A(L).GT.T) GO TO 60
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN T
   70 K = K + 1
      IF (A(K).LT.T) GO TO 70
C                                  INTERCHANGE THESE ELEMENTS
      IF (K.LE.L) GO TO 50
C                                  SAVE UPPER AND LOWER SUBSCRIPTS OF
C                                  THE ARRAY YET TO BE SORTED
      IF (L-I.LE.J-K) GO TO 80
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 100
   80 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 100
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
   90 M = M - 1
      IF (M.EQ.0) RETURN
      I = IL(M)
      J = IU(M)
  100 IF (J-I.GE.1) GO TO 30
      IF (I.EQ.1) GO TO 10
      I = I - 1
  110 I = I + 1
      IF (I.EQ.J) GO TO 90
      T = A(I+1)
      IT = IR(I+1)
      RT = RR(I+1)
      IF (A(I).LE.T) GO TO 110
      K = I
  120 A(K+1) = A(K)
      IR(K+1) = IR(K)
      RR(K+1) = RR(K)
      K = K - 1
      IF (T.LT.A(K)) GO TO 120
      A(K+1) = T
      IR(K+1) = IT
      RR(K+1) = RT
      GO TO 110
      END
*SRTRI
      SUBROUTINE SRTRI(A, LA, IR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C   FUNCTION     SRTRI  - SORT ARRAY A ON AN INTEGER ARRAY IR.
C                           IF THE INTEGER ARRAY IS A PERMUTATION
C                           VECTOR FOR THE ARRAY, THEN THE
C                           ARRAY IS RESTORED TO ITS ORIGINAL
C                           (UNPERMUTED) ORDER.
C                           PERMUTATIONS RETURNED
C   USAGE               - CALL SRTRI (A,LA,IR)
C   PARAMETERS   A(LA)  - ON INPUT, CONTAINS THE ARRAY TO BE SORTED
C                         ON OUTPUT, A CONTAINS THE SORTED ARRAY
C                LA     - INPUT VARIABLE CONTAINING THE NUMBER OF
C                           ELEMENTS IN THE ARRAY TO BE SORTED
C                IR(LA) - ON INPUT, CONTAINS THE INTEGER KEY ARRAY
C                         ON OUTPUT, CONTAINS THE SORTED KEY ARRAY
C                           1,2,...,LA.
C                       - THEN ON OUTPUT, IR CONTAINS A RECORD OF THE
C                           PERMUTATIONS MADE ON THE VECTOR A.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LA
C
C  ARRAY ARGUMENTS
      REAL
     +   A(LA)
      INTEGER
     +   IR(LA)
C
C  LOCAL SCALARS
      REAL
     +   R,T,TT
      INTEGER
     +   I,IJ,IT,ITT,J,K,L,M
C
C  LOCAL ARRAYS
      INTEGER
     +   IL(21),IU(21)
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT
C
C
      M = 1
      I = 1
      J = LA
      R = .375E0
   10 IF (I.EQ.J) GO TO 90
      IF (R.GT.0.5898437E0) GO TO 20
      R = R + 3.90625E-2
      GO TO 30
   20 R = R - .21875E0
   30 K = I
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION IT
      IJ = I + INT((J-I)*R)
      T = A(IJ)
      IT = IR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN IT, INTERCHANGE WITH IT
      IF (IR(I).LE.IT) GO TO 40
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
   40 L = J
C                                  IF LAST ELEMENT OF ARRAY IS LESS THAN
C                                  IT, INTERCHANGE WITH IT
      IF (IR(J).GE.IT) GO TO 60
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      IR(IJ) = IR(J)
      IR(J) = IT
      IT = IR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN IT, INTERCHANGE WITH IT
      IF (IR(I).LE.IT) GO TO 60
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      GO TO 60
   50 TT = A(L)
      A(L) = A(K)
      A(K) = TT
      ITT = IR(L)
      IR(L) = IR(K)
      IR(K) = ITT
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN IT
   60 L = L - 1
      IF (IR(L).GT.IT) GO TO 60
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN IT
   70 K = K + 1
      IF (IR(K).LT.IT) GO TO 70
C                                  INTERCHANGE THESE ELEMENTS
      IF (K.LE.L) GO TO 50
C                                  SAVE UPPER AND LOWER SUBSCRIPTS OF
C                                  THE ARRAY YET TO BE SORTED
      IF (L-I.LE.J-K) GO TO 80
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 100
   80 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 100
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
   90 M = M - 1
      IF (M.EQ.0) RETURN
      I = IL(M)
      J = IU(M)
  100 IF (J-I.GE.1) GO TO 30
      IF (I.EQ.1) GO TO 10
      I = I - 1
  110 I = I + 1
      IF (I.EQ.J) GO TO 90
      T = A(I+1)
      IT = IR(I+1)
      IF (IR(I).LE.IT) GO TO 110
      K = I
  120 A(K+1) = A(K)
      IR(K+1) = IR(K)
      K = K - 1
      IF (IT.LT.IR(K)) GO TO 120
      A(K+1) = T
      IR(K+1) = IT
      GO TO 110
      END
*SRTRRI
      SUBROUTINE SRTRRI(A, RR, LA, IR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SORTS THE LENGTH LA INTEGER ARRAY IR, THE LENGTH LA
C     ARRAY A, AND THE LENGTH LA ARRAY RR INTO ASCENDING
C     ORDER, BASED ON THE VALUES IN IR.  THE INTEGER ARRAY IR
C     CONSTITUTES THE KEY.  THE OTHER ARRAYS ARE CARRIED ALONG.
C     ORDINARILY THE ARRAY IR CONTAINS THE PERMUTATION VECTOR
C     RESULTING FROM AN APPLICATION OF THE ROUTINE SRTIRR, SO THAT
C     SORTING ON IR RESTORES A TO THE ORDER THAT IT HAD BEFORE
C     SRTIRR WAS APPLIED.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C        (BASED CLOSELY ON THE IMSL CDC LIBRARY 3 ROUTINE VSORTP)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LA
C
C  ARRAY ARGUMENTS
      REAL
     +   A(LA),RR(LA)
      INTEGER
     +   IR(LA)
C
C  LOCAL SCALARS
      REAL
     +   R,RT,RTT,T,TT
      INTEGER
     +   I,IJ,IT,ITT,J,K,L,M
C
C  LOCAL ARRAYS
      INTEGER
     +   IL(21),IU(21)
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL A(LA)
C        INPUT/OUTPUT PARAMETER.  THE ARRAY TO BE SORTED ON
C        THE BASIS OF THE VALUES IN IR.  IF IR IS A PERMUTATION
C        VECTOR PRODUCED ORIGINALLY IN A SORT OF A, THEN THIS
C        OPERATION RESTORES A TO ITS ORIGINAL ORDER.
C     INTEGER I
C        *
C     INTEGER IJ
C        *
C     INTEGER IL(21)
C        *
C     INTEGER IR(LA)
C        INPUT/OUTPUT PARAMETER.  THE INTEGER KEY ARRAY.  ORDINARILY
C        IT WILL BE A PERMUTATION VECTOR PRODUCED BY SOME PREVIOUS
C        SORT OF A AND RR ON A, SO THAT SORTING ON IR WILL RESTORE
C        A TO ITS ORIGINAL ORDER.
C     INTEGER IT
C        *
C     INTEGER ITT
C        *
C     INTEGER IU(21)
C        *
C     INTEGER J
C        *
C     INTEGER K
C        *
C     INTEGER L
C        *
C     INTEGER LA
C        INPUT PARAMETER.  THE LENGTH OF THE INPUT/OUTPUT PARAMETERS
C        A, RR, AND IR.
C     INTEGER M
C        *
C     REAL R
C        *
C     REAL RR(LA)
C        INPUT/OUTPUT PARAMETER.  THE ARRAY CARRIED ALONG IN
C        THE SORT.  IT MIGHT BE THE SET OF WEIGHTS FOR A.
C     REAL RT
C        *
C     REAL RTT
C        *
C     REAL T
C        *
C     REAL TT
C        *
C
      M = 1
      I = 1
      J = LA
      R = .375E0
   10 IF (I.EQ.J) GO TO 90
      IF (R.GT.0.5898437E0) GO TO 20
      R = R + 3.90625E-2
      GO TO 30
   20 R = R - .21875E0
   30 K = I
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION IT
      IJ = I + INT((J-I)*R)
      T = A(IJ)
      IT = IR(IJ)
      RT = RR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN IT, INTERCHANGE WITH IT
      IF (IR(I).LE.IT) GO TO 40
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      RR(IJ) = RR(I)
      RR(I) = RT
      RT = RR(IJ)
   40 L = J
C                                  IF LAST ELEMENT OF ARRAY IS LESS THAN
C                                  IT, INTERCHANGE WITH IT
      IF (IR(J).GE.IT) GO TO 60
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      IR(IJ) = IR(J)
      IR(J) = IT
      IT = IR(IJ)
      RR(IJ) = RR(J)
      RR(J) = RT
      RT = RR(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN IT, INTERCHANGE WITH IT
      IF (IR(I).LE.IT) GO TO 60
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      RR(IJ) = RR(I)
      RR(I) = RT
      RT = RR(IJ)
      GO TO 60
   50 TT = A(L)
      A(L) = A(K)
      A(K) = TT
      ITT = IR(L)
      IR(L) = IR(K)
      IR(K) = ITT
      RTT = RR(L)
      RR(L) = RR(K)
      RR(K) = RTT
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN IT
   60 L = L - 1
      IF (IR(L).GT.IT) GO TO 60
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN IT
   70 K = K + 1
      IF (IR(K).LT.IT) GO TO 70
C                                  INTERCHANGE THESE ELEMENTS
      IF (K.LE.L) GO TO 50
C                                  SAVE UPPER AND LOWER SUBSCRIPTS OF
C                                  THE ARRAY YET TO BE SORTED
      IF (L-I.LE.J-K) GO TO 80
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 100
   80 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 100
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
   90 M = M - 1
      IF (M.EQ.0) RETURN
      I = IL(M)
      J = IU(M)
  100 IF (J-I.GE.1) GO TO 30
      IF (I.EQ.1) GO TO 10
      I = I - 1
  110 I = I + 1
      IF (I.EQ.J) GO TO 90
      T = A(I+1)
      IT = IR(I+1)
      RT = RR(I+1)
      IF (IR(I).LE.IT) GO TO 110
      K = I
  120 A(K+1) = A(K)
      IR(K+1) = IR(K)
      RR(K+1) = RR(K)
      K = K - 1
      IF (IT.LT.IR(K)) GO TO 120
      A(K+1) = T
      IR(K+1) = IT
      RR(K+1) = RT
      GO TO 110
      END
*SSIDI
      SUBROUTINE SSIDI(A,LDA,N,KPVT,DET,INERT,WORK,JOB)
C
C     LATEST REVISION  -  JANUARY 24, 1990  (JRD)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER JOB,LDA,N
C
C  ARRAY ARGUMENTS
      REAL A(LDA,*),DET(2),WORK(*)
      INTEGER INERT(3),KPVT(*)
C
C  LOCAL SCALARS
      REAL AK,AKKP1,AKP1,D,T,TEMP,TEN
      INTEGER J,JB,K,KM1,KS,KSTEP
      LOGICAL NODET,NOERT,NOINV
C
C  EXTERNAL FUNCTIONS
      REAL SDOT
      EXTERNAL SDOT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SAXPY,SCOPY,SSWAP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,IABS,MOD
C
C     SSIDI COMPUTES THE DETERMINANT, INERTIA AND INVERSE
C     OF A REAL SYMMETRIC MATRIX USING THE FACTORS FROM SSIFA.
C
C     ON ENTRY
C
C        A       REAL(LDA,N)
C                THE OUTPUT FROM SSIFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY A.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX A.
C
C        KPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SSIFA.
C
C        WORK    REAL(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                JOB HAS THE DECIMAL EXPANSION  ABC  WHERE
C                   IF  C .NE. 0, THE INVERSE IS COMPUTED,
C                   IF  B .NE. 0, THE DETERMINANT IS COMPUTED,
C                   IF  A .NE. 0, THE INERTIA IS COMPUTED.
C
C                FOR EXAMPLE, JOB = 111  GIVES ALL THREE.
C
C     ON RETURN
C
C        VARIABLES NOT REQUESTED BY JOB ARE NOT USED.
C
C        A      CONTAINS THE UPPER TRIANGLE OF THE INVERSE OF
C               THE ORIGINAL MATRIX.  THE STRICT LOWER TRIANGLE
C               IS NEVER REFERENCED.
C
C        DET    REAL(2)
C               DETERMINANT OF ORIGINAL MATRIX.
C               DETERMINANT = DET(1) * 10.0**DET(2)
C               WITH 1.0 .LE. ABS(DET(1)) .LT. 10.0
C               OR DET(1) = 0.0.
C
C        INERT  INTEGER(3)
C               THE INERTIA OF THE ORIGINAL MATRIX.
C               INERT(1)  =  NUMBER OF POSITIVE EIGENVALUES.
C               INERT(2)  =  NUMBER OF NEGATIVE EIGENVALUES.
C               INERT(3)  =  NUMBER OF ZERO EIGENVALUES.
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO MAY OCCUR IF THE INVERSE IS REQUESTED
C        AND  SSICO  HAS SET RCOND .EQ. 0.0
C        OR  SSIFA  HAS SET  INFO .NE. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SCOPY,SDOT,SSWAP
C     Fortran ABS,IABS,MOD
C
C
      NOINV = MOD(JOB,10) .EQ. 0
      NODET = MOD(JOB,100)/10 .EQ. 0
      NOERT = MOD(JOB,1000)/100 .EQ. 0
C
      TEN = 10.0E0
C
      IF (NODET .AND. NOERT) GO TO 140
         IF (NOERT) GO TO 10
            INERT(1) = 0
            INERT(2) = 0
            INERT(3) = 0
   10    CONTINUE
         IF (NODET) GO TO 20
            DET(1) = 1.0E0
            DET(2) = 0.0E0
   20    CONTINUE
         T = 0.0E0
         DO 130 K = 1, N
            D = A(K,K)
C
C           CHECK IF 1 BY 1
C
            IF (KPVT(K) .GT. 0) GO TO 50
C
C              2 BY 2 BLOCK
C              USE DET (D  S)  =  (D/T * C - T) * T  ,  T = ABS(S)
C                      (S  C)
C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
C
               IF (T .NE. 0.0E0) GO TO 30
                  T = ABS(A(K,K+1))
                  D = (D/T)*A(K+1,K+1) - T
               GO TO 40
   30          CONTINUE
                  D = T
                  T = 0.0E0
   40          CONTINUE
   50       CONTINUE
C
            IF (NOERT) GO TO 60
               IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1
               IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1
               IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1
   60       CONTINUE
C
            IF (NODET) GO TO 120
               DET(1) = D*DET(1)
               IF (DET(1) .EQ. 0.0E0) GO TO 110
   70             IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80
                     DET(1) = TEN*DET(1)
                     DET(2) = DET(2) - 1.0E0
                  GO TO 70
   80             CONTINUE
   90             IF (ABS(DET(1)) .LT. TEN) GO TO 100
                     DET(1) = DET(1)/TEN
                     DET(2) = DET(2) + 1.0E0
                  GO TO 90
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
  130    CONTINUE
  140 CONTINUE
C
C     COMPUTE INVERSE(A)
C
      IF (NOINV) GO TO 270
         K = 1
  150    IF (K .GT. N) GO TO 260
            KM1 = K - 1
            IF (KPVT(K) .LT. 0) GO TO 180
C
C              1 BY 1
C
               A(K,K) = 1.0E0/A(K,K)
               IF (KM1 .LT. 1) GO TO 170
                  CALL SCOPY(KM1,A(1,K),1,WORK,1)
                  DO 160 J = 1, KM1
                     A(J,K) = SDOT(J,A(1,J),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  160             CONTINUE
                  A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1)
  170          CONTINUE
               KSTEP = 1
            GO TO 220
  180       CONTINUE
C
C              2 BY 2
C
               T = ABS(A(K,K+1))
               AK = A(K,K)/T
               AKP1 = A(K+1,K+1)/T
               AKKP1 = A(K,K+1)/T
               D = T*(AK*AKP1 - 1.0E0)
               A(K,K) = AKP1/D
               A(K+1,K+1) = AK/D
               A(K,K+1) = -AKKP1/D
               IF (KM1 .LT. 1) GO TO 210
                  CALL SCOPY(KM1,A(1,K+1),1,WORK,1)
                  DO 190 J = 1, KM1
                     A(J,K+1) = SDOT(J,A(1,J),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1)
  190             CONTINUE
                  A(K+1,K+1) = A(K+1,K+1) + SDOT(KM1,WORK,1,A(1,K+1),1)
                  A(K,K+1) = A(K,K+1) + SDOT(KM1,A(1,K),1,A(1,K+1),1)
                  CALL SCOPY(KM1,A(1,K),1,WORK,1)
                  DO 200 J = 1, KM1
                     A(J,K) = SDOT(J,A(1,J),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  200             CONTINUE
                  A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1)
  210          CONTINUE
               KSTEP = 2
  220       CONTINUE
C
C           SWAP
C
            KS = IABS(KPVT(K))
            IF (KS .EQ. K) GO TO 250
               CALL SSWAP(KS,A(1,KS),1,A(1,K),1)
               DO 230 JB = KS, K
                  J = K + KS - JB
                  TEMP = A(J,K)
                  A(J,K) = A(KS,J)
                  A(KS,J) = TEMP
  230          CONTINUE
               IF (KSTEP .EQ. 1) GO TO 240
                  TEMP = A(KS,K+1)
                  A(KS,K+1) = A(K,K+1)
                  A(K,K+1) = TEMP
  240          CONTINUE
  250       CONTINUE
            K = K + KSTEP
         GO TO 150
  260    CONTINUE
  270 CONTINUE
      RETURN
      END
*SSIFA
      SUBROUTINE SSIFA(A,LDA,N,KPVT,INFO)
C
C     LATEST REVISION  -  JANUARY 24, 1990
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER INFO,LDA,N
C
C  ARRAY ARGUMENTS
      REAL A(LDA,*)
      INTEGER KPVT(*)
C
C  LOCAL SCALARS
      REAL ABSAKK,AK,AKM1,ALPHA,BK,BKM1,COLMAX,DENOM,MULK,MULKM1,ROWMAX,
     +   T
      INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP
      LOGICAL SWAP
C
C  EXTERNAL FUNCTIONS
      INTEGER ISAMAX
      EXTERNAL ISAMAX
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SAXPY,SSWAP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,AMAX1,SQRT
C
C
C     SSIFA FACTORS A REAL SYMMETRIC MATRIX BY ELIMINATION
C     WITH SYMMETRIC PIVOTING.
C
C     TO SOLVE  A*X = B , FOLLOW SSIFA BY SSISL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW SSIFA BY SSISL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW SSIFA BY SSIDI.
C     TO COMPUTE  INERTIA(A) , FOLLOW SSIFA BY SSIDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW SSIFA BY SSIDI.
C
C     ON ENTRY
C
C        A       REAL(LDA,N)
C                THE SYMMETRIC MATRIX TO BE FACTORED.
C                ONLY THE DIAGONAL AND UPPER TRIANGLE ARE USED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH
C                WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = U*D*TRANS(U)
C                WHERE  U  IS A PRODUCT OF PERMUTATION AND UNIT
C                UPPER TRIANGULAR MATRICES , TRANS(U) IS THE
C                TRANSPOSE OF  U , AND  D  IS BLOCK DIAGONAL
C                WITH 1 BY 1 AND 2 BY 2 BLOCKS.
C
C        KPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF THE K-TH PIVOT BLOCK IS SINGULAR. THIS IS
C                     NOT AN ERROR CONDITION FOR THIS SUBROUTINE,
C                     BUT IT DOES INDICATE THAT SSISL OR SSIDI MAY
C                     DIVIDE BY ZERO IF CALLED.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSWAP,ISAMAX
C     Fortran ABS,AMAX1,SQRT
C
C
C     INITIALIZE
C
C     ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE.
      ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0
C
      INFO = 0
C
C     MAIN LOOP ON K, WHICH GOES FROM N TO 1.
C
      K = N
   10 CONTINUE
C
C        LEAVE THE LOOP IF K=0 OR K=1.
C
C     ...EXIT
         IF (K .EQ. 0) GO TO 200
         IF (K .GT. 1) GO TO 20
            KPVT(1) = 1
            IF (A(1,1) .EQ. 0.0E0) INFO = 1
C     ......EXIT
            GO TO 200
   20    CONTINUE
C
C        THIS SECTION OF CODE DETERMINES THE KIND OF
C        ELIMINATION TO BE PERFORMED.  WHEN IT IS COMPLETED,
C        KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND
C        SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS
C        REQUIRED.
C
         KM1 = K - 1
         ABSAKK = ABS(A(K,K))
C
C        DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C        COLUMN K.
C
         IMAX = ISAMAX(K-1,A(1,K),1)
         COLMAX = ABS(A(IMAX,K))
         IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30
            KSTEP = 1
            SWAP = .FALSE.
         GO TO 90
   30    CONTINUE
C
C           DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C           ROW IMAX.
C
            ROWMAX = 0.0E0
            IMAXP1 = IMAX + 1
            DO 40 J = IMAXP1, K
               ROWMAX = AMAX1(ROWMAX,ABS(A(IMAX,J)))
   40       CONTINUE
            IF (IMAX .EQ. 1) GO TO 50
               JMAX = ISAMAX(IMAX-1,A(1,IMAX),1)
               ROWMAX = AMAX1(ROWMAX,ABS(A(JMAX,IMAX)))
   50       CONTINUE
            IF (ABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60
               KSTEP = 1
               SWAP = .TRUE.
            GO TO 80
   60       CONTINUE
            IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70
               KSTEP = 1
               SWAP = .FALSE.
            GO TO 80
   70       CONTINUE
               KSTEP = 2
               SWAP = IMAX .NE. KM1
   80       CONTINUE
   90    CONTINUE
         IF (AMAX1(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100
C
C           COLUMN K IS ZERO.  SET INFO AND ITERATE THE LOOP.
C
            KPVT(K) = K
            INFO = K
         GO TO 190
  100    CONTINUE
         IF (KSTEP .EQ. 2) GO TO 140
C
C           1 X 1 PIVOT BLOCK.
C
            IF (.NOT.SWAP) GO TO 120
C
C              PERFORM AN INTERCHANGE.
C
               CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K),1)
               DO 110 JJ = IMAX, K
                  J = K + IMAX - JJ
                  T = A(J,K)
                  A(J,K) = A(IMAX,J)
                  A(IMAX,J) = T
  110          CONTINUE
  120       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            DO 130 JJ = 1, KM1
               J = K - JJ
               MULK = -A(J,K)/A(K,K)
               T = MULK
               CALL SAXPY(J,T,A(1,K),1,A(1,J),1)
               A(J,K) = MULK
  130       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = K
            IF (SWAP) KPVT(K) = IMAX
         GO TO 190
  140    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            IF (.NOT.SWAP) GO TO 160
C
C              PERFORM AN INTERCHANGE.
C
               CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1)
               DO 150 JJ = IMAX, KM1
                  J = KM1 + IMAX - JJ
                  T = A(J,K-1)
                  A(J,K-1) = A(IMAX,J)
                  A(IMAX,J) = T
  150          CONTINUE
               T = A(K-1,K)
               A(K-1,K) = A(IMAX,K)
               A(IMAX,K) = T
  160       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            KM2 = K - 2
            IF (KM2 .EQ. 0) GO TO 180
               AK = A(K,K)/A(K-1,K)
               AKM1 = A(K-1,K-1)/A(K-1,K)
               DENOM = 1.0E0 - AK*AKM1
               DO 170 JJ = 1, KM2
                  J = KM1 - JJ
                  BK = A(J,K)/A(K-1,K)
                  BKM1 = A(J,K-1)/A(K-1,K)
                  MULK = (AKM1*BK - BKM1)/DENOM
                  MULKM1 = (AK*BKM1 - BK)/DENOM
                  T = MULK
                  CALL SAXPY(J,T,A(1,K),1,A(1,J),1)
                  T = MULKM1
                  CALL SAXPY(J,T,A(1,K-1),1,A(1,J),1)
                  A(J,K) = MULK
                  A(J,K-1) = MULKM1
  170          CONTINUE
  180       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = 1 - K
            IF (SWAP) KPVT(K) = -IMAX
            KPVT(K-1) = KPVT(K)
  190    CONTINUE
         K = K - KSTEP
      GO TO 10
  200 CONTINUE
      RETURN
      END
*STAT1
      SUBROUTINE STAT1(Y, N, YMED, YMIN, YMAX, YMIDRG, YRANGE, NCELLS,
     +   YLB, YUB, YDISTR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS COMPUTES STATISTICS FOR A VECTOR Y THAT REQUIRE OR CAN
C     MAKE USE OF SORTEDNESS IN THE Y VECTOR.
C
C     THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS
C     CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTED BY
C     SALLY PEAVY.  THE ORIGINAL ADAPTATION TO STARPAC WAS MADE
C     BY JANET DONALDSON.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YLB,YMAX,YMED,YMIDRG,YMIN,YRANGE,YUB
      INTEGER
     +   N,NCELLS
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(N),YDISTR(NCELLS)
C
C  LOCAL SCALARS
      REAL
     +   DELY,YT
      INTEGER
     +   I,IC,IC1,L,M,M1
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELY
C        THE WIDTH OF AN INTERVAL ONE TENTH THE RANGE OF THE
C        DATA IN Y.
C     INTEGER I
C        A LOOP INDEX.
C     INTEGER IC
C        PREVIOUS SIGN IN RUNS CALCULATION.
C     INTEGER IC1
C        COUNT IN FREQUENCY DISTRIBUTION CALCULATIONS.
C     INTEGER L
C        A LOOP INDEX.
C     INTEGER M
C        A LOOP INDEX.
C     INTEGER M1
C        WHEN N IS EVEN, M1 IS M + 1, OTHERWISE IT IS M.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y AND WT.
C     INTEGER NCELLS
C        THE NUMBER OF CELLS IN THE FREQUENCY DISTRIBUTION.
C     REAL Y(N)
C        INPUT PARAMETER.  A SET OF N DATA POINTS, SORTED
C        INTO ASCENDING ORDER.
C     REAL YDISTR(NCELLS)
C        OUTPUT PARAMETER.  THE NUMBERS OF Y VALUES WITH
C        POSITIVE WEIGHTS IN EACH OF NCELLS EQUAL LENGTH INTERVALS
C        THAT DIVIDE THE RANGE OF Y VALUES.
C     REAL YLB
C        THE LOWER BOUND FOR THE FREQUENCY DISTRIBUTION.
C        IF YLB = YUB, THE MINIMUM OBSERVATION WILL BE USED.
C     REAL YMAX
C        OUTPUT PARAMETER.  THE MAXIMUM OF THE OBSERVATIONS Y HAVING
C        POSITIVE WEIGHT.
C     REAL YMED
C        OUTPUT PARAMETER.  THE MEDIAN OF THE OBSERVATIONS Y.
C     REAL YMIDRG
C        OUTPUT PARAMETER.  THE MIDRANGE OF THE OBSERVATIONS Y.
C     REAL YMIN
C        OUTPUT PARAMETER.  THE MINIMUM OF THE OBSERVATIONS Y HAVING
C        POSITIVE WEIGHT.
C     REAL YRANGE
C        THE RANGE OF THE OBSERVATIONS Y.
C     REAL YT
C        THE MAXIMUM VALUE IN EACH INTERVAL IN THE FREQUENCY
C        DISTRIBUTIONS CALCULATIONS.
C     REAL YUB
C        THE UPPER BOUND FOR THE FREQUENCY DISTRIBUTION.
C        IF YLB = YUB, THE MAXIMUM OBSERVATION WILL BE USED.
C
C     CALCULATE THE MEDIAN, MIDRANGE, RANGE, AND EXTREMA.
C
      M = (N+1)/2
      M1 = M
      IF (MOD(N,2).EQ.0) M1 = M1 + 1
      YMED = (Y(M)+Y(M1))/2.0E0
      YMIDRG = (Y(1)+Y(N))/2.0E0
      YRANGE = Y(N) - Y(1)
      YMIN = Y(1)
      YMAX = Y(N)
C
C     COMPUTE FREQUENCY DISTRIBUTION.
C
      IF (NCELLS.LE.0) RETURN
      IC1 = 0
      IF (NCELLS.EQ.1) GO TO 40
C
      DELY = YRANGE
      YT = YMIN
      IF (YLB.GE.YUB) GO TO 5
         DELY = YUB - YLB
         YT = YLB
    5 CONTINUE
      DELY = DELY / NCELLS
      YT = YT + DELY
      L = 0
      DO 30 I=2,NCELLS
         IC = 0
   10    L = L + 1
         IF (L.GT.N) GO TO 20
         IF (Y(L).GT.YT) GO TO 20
         IC = IC + 1
         IC1 = IC1 + 1
         GO TO 10
   20    YDISTR(I-1) = IC
         L = L - 1
         YT = YT + DELY
   30 CONTINUE
   40 YDISTR(NCELLS) = N - IC1
      RETURN
      END
*STAT1W
      SUBROUTINE STAT1W(Y, WT, N, YMED, YMIN, YMAX, YMIDRG, YRANGE,
     +   NCELLS, YLB, YUB, YDISTR, NNZW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS COMPUTES STATISTICS FOR A VECTOR Y THAT REQUIRE OR CAN
C     MAKE USE OF SORTEDNESS IN THE VECTOR.  WEIGHTS ARE USED.
C
C     THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS
C     CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTED BY
C     SALLY PEAVY.  THE ORIGINAL ADAPTATION TO STARPAC WAS MADE
C     BY JANET DONALDSON.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   YLB,YMAX,YMED,YMIDRG,YMIN,YRANGE,YUB
      INTEGER
     +   N,NCELLS,NNZW
C
C  ARRAY ARGUMENTS
      REAL
     +   WT(N),Y(N),YDISTR(NCELLS)
C
C  LOCAL SCALARS
      REAL
     +   DELY,YT
      INTEGER
     +   I,IC,IC1,KK,L,M,M1,MAX,MAXY,MINY,N2
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELY
C        THE WIDTH OF AN INTERVAL ONE TENTH THE RANGE OF THE
C        DATA IN Y.
C     INTEGER I
C        A LOOP INDEX.
C     INTEGER IC
C        PREVIOUS SIGN IN RUNS CALCULATION.
C     INTEGER IC1
C        COUNT IN FREQUENCY DISTRIBUTION CALCULATIONS.
C     INTEGER KK
C        A BACKWARDS, BOULDER, COLORADO LOOP INDEX.
C     INTEGER L
C        A LOOP INDEX.
C     INTEGER M
C        A LOOP INDEX.
C     INTEGER MAX
C        INDEX OF A MAXIMUM ELEMENT.
C     INTEGER MAXY
C        LAST ELEMENT OF Y, THE LARGEST ONE.
C     INTEGER MINY
C        FIRST ELEMENT OF Y, THE LEAST ONE.
C     INTEGER M1
C        ...
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y AND WT.
C     INTEGER NCELLS
C        THE NUMBER OF CELLS IN THE FREQUENCY DISTRIBUTION.
C     INTEGER NNZW
C        INPUT PARAMETER.  THE NUMBER OF POSITIVE ELEMENTS IN WT.
C     INTEGER N2
C        (NNZW + 1)/2
C     REAL WT(N)
C        INPUT PARAMETER.  THE VECTOR OF WEIGHTS FOR THE
C        Y OBSERVATIONS.
C     REAL Y(N)
C        INPUT PARAMETER.  A SET OF N DATA POINTS, SORTED
C        INTO ASCENDING ORDER.
C     REAL YDISTR(NCELLS)
C        OUTPUT PARAMETER.  THE NUMBERS OF Y VALUES WITH
C        POSITIVE WEIGHTS IN EACH OF TEN EQUAL LENGTH INTERVALS.
C        THAT DIVIDE THE RANGE OF Y VALUES.
C     REAL YLB
C        THE LOWER BOUND FOR THE FREQUENCY DISTRIBUTION.
C        IF YLB = YUB, THE MINIMUM OBSERVATION WILL BE USED.
C     REAL YMAX
C        OUTPUT PARAMETER.  THE MAXIMUM OF THE OBSERVATIONS Y HAVING
C        POSITIVE WEIGHT.
C     REAL YMED
C        OUTPUT PARAMETER.  THE MEDIAN OF THE OBSERVATIONS Y.
C     REAL YMIDRG
C        OUTPUT PARAMETER.  THE MIDRANGE OF THE OBSERVATIONS Y.
C     REAL YMIN
C        OUTPUT PARAMETER.  THE MINIMUM OF THE OBSERVATIONS Y HAVING
C        POSITIVE WEIGHT.
C     REAL YRANGE
C        OUTPUT PARAMETER.  THE RANGE OF THE OBSERVATIONS Y.
C     REAL YT
C        THE MAXIMUM VALUE IN EACH INTERVAL IN THE FREQUENCY
C        DISTRIBUTIONS CALCULATIONS.
C     REAL YUB
C        THE UPPER BOUND FOR THE FREQUENCY DISTRIBUTION.
C        IF YLB = YUB, THE MAXIMUM OBSERVATION WILL BE USED.
C
C     CALCULATE THE MEDIAN.
C
      N2 = (NNZW+1)/2
      M = 1
      DO 10 I=1,N
         IF (I.GT.N2) GO TO 20
         M = I
         IF (WT(M).LE.0.0E0) N2 = N2 + 1
   10 CONTINUE
   20 M1 = M
      IF (MOD(NNZW,2).NE.0) GO TO 40
      DO 30 M1=M,N
         IF (WT(M1).GT.0.0E0) GO TO 40
   30 CONTINUE
   40 YMED = (Y(I)+Y(M1))/2.0E0
C
C     CALCULATE THE MIDRANGE, RANGE, MINIMUM, AND MAXIMUM.
C
      MAX = N - NNZW + 1
      DO 50 I=1,MAX
         MINY = I
         IF (WT(MINY).GT.0.0E0) GO TO 60
   50 CONTINUE
   60 DO 70 I=1,MAX
         KK = N + 1 - I
         MAXY = KK
         IF (WT(MAXY).GT.0.0E0) GO TO 80
   70 CONTINUE
   80 YMIDRG = (Y(MINY)+Y(MAXY))/2.0E0
      YRANGE = Y(MAXY) - Y(MINY)
      YMIN = Y(MINY)
      YMAX = Y(MAXY)
C
C     COMPUTE FREQUENCY DISTRIBUTION
C
      DELY = YRANGE
      YT = YMIN
      IF (YLB.GE.YUB) GO TO 5
         DELY = YUB - YLB
         YT = YLB
    5 CONTINUE
      DELY = DELY / NCELLS
      YT = YT + DELY
      L = 0
      IC1 = 0
      DO 110 I=2,NCELLS
         IC = 0
   90    L = L + 1
         IF (L.GT.N) GO TO 100
         IF (WT(L).LE.0.0E0) GO TO 90
         IF (Y(L).GT.YT) GO TO 100
         IC = IC + 1
         IC1 = IC1 + 1
         GO TO 90
  100    YDISTR(I-1) = IC
         L = L - 1
         YT = YT + DELY
  110 CONTINUE
      YDISTR(NCELLS) = NNZW - IC1
      RETURN
      END
*STAT2
      SUBROUTINE STAT2(Y, N, STS, SUMDA, SUMDI, SUMD2, SUMD3, SUMD4)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES FOR A VECTOR Y THE STATISTICS THAT DO
C     NOT REQUIRE SORTING OF THE VECTOR, THAT IS, THOSE NOT COMPUTED
C     BY STAT1.  NO WEIGHTS ARE USED.
C
C     THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS
C     CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTEN BY
C     SALLY PEAVY.  THE ORIGINAL ADAPTATION TO STARPAC WAS
C     DONE BY JANET DONALDSON.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUMD2,SUMD3,SUMD4,SUMDA,SUMDI
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   STS(53),Y(N)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   DIF,T,TA,TK1,TK2
      INTEGER
     +   I,IC,ICI,IDRUNS,IMINUS,IPLUS,IRUN
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFF,PPFCHS,PPFT
      EXTERNAL CDFF,PPFCHS,PPFT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DIF
C        THE SUM OF THE DIFFERENCES BETWEEN SUCCEEDING ELEMENTS
C        IN Y.
C     INTEGER I
C        A LOOP INDEX.
C     INTEGER IC
C        PREVIOUS SIGN IN RUNS CALCULATION.
C     INTEGER ICI
C        CURRENT SIGN IN RUNS CALCULATION.
C     INTEGER IDRUNS
C        THE NUMBER OF RUNS.
C     INTEGER IERR
C        AN ERROR FLAG SET IN COMMON ERRCHK.
C     INTEGER IMINUS, IPLUS
C        COUNTS OF SIGNS OF DEVIATIONS.
C     INTEGER IRUN
C        THE NUMBER OF RUNS UP AND DOWN.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y AND WT.
C     REAL STS(53)
C        OUTPUT PARAMETER.  THE VECTOR OF 53 STATISTICS COMPUTED.
C        ROW STATISTIC                    ROW STATISTIC
C         1  LENGTH OF VECTOR             TESTS FOR NONRANDOMNESS
C         2  NUMBER OF NONZERO WEIGHTS    23  NUMBER OF RUNS UP AND DOWN
C        MEASURES OF LOCATION             24  EXPECTED NUMBER OF RUNS
C         3  UNWEIGHTED MEAN              25  S.D. OF NUMBER OF RUNS
C         4  WEIGHTED MEAN                26  MEAN SQR. SUCCESSIVE DIFF.
C         5  MEDIAN                       27  MEAN SQR. SUCC. DIFF./VAR.
C         6  MID-RANGE                    DEVIATIONS FROM WTD MEAN
C         7  25 P.C. UNWTD. TRIMMED MEAN  28  NUMBER OF + SIGNS
C         8  25 P.C. WTD. TRIMMED MEAN    29  NUMBER OF - SIGNS
C        MEASURES OF DISPERSION           30  NUMBER OF RUNS
C         9  STANDARD DEVIATION (S.D.)    31  EXPECTED NUMBER OF RUNS
C        10  S.D. OF MEAN                 32  S.D. OF RUNS
C        11  RANGE                        33  DIFF./S.D. OF RUNS
C        12  MEAN VARIATION               OTHER STATISTICS
C        13  VARIANCE (VAR.)              34  MINIMUM
C        14  COEFFICIENT OF VARIATION     35  MAXIMUM
C        CONFIDENCE INTERVALS             36  BETA 1
C        15  LOWER CONFIDENCE LIMIT, MEAN 37  BETA 2
C        16  UPPER CONFIDENCE LIMIT, MEAN 38  WTD. SUM OF VALUES
C        17  LOWER CONFIDENCE LIMIT, S.D. 39  WTD. SUM OF SQUARES
C        18  UPPER CONFIDENCE LIMIT, S.D. 40  WTD. SUM OF SQRD. DEVS.
C        LINEAR TREND STATISTICS          41  STUDENTS T
C        19  SLOPE                        42  WTD. SUM OF ABS. VALUES
C        20  S.D. OF SLOPE                43  WTD. AVG. ABS. VALUES
C        21  SLOPE/S.D. OF SLOPE = T      44-53 FREQ. DISTRIBUTION
C        22  PROB ( X .GT. ABS(OBS. T))
C     REAL SUMDA
C        INPUT PARAMETER.  THE SUM OF THE ABSOLUTE VALUES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMDI
C        INPUT PARAMETER.  THE SUM OF THE PRODUCTS OF I AND THE
C        ITH DIFFERENCE DIFF.
C     REAL SUMD2
C        INPUT PARAMETER.  THE SUM OF THE SQUARES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD3
C        INPUT PARAMETER.  THE SUM OF THE CUBES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD4
C        INPUT PARAMETER.  THE SUM OF THE HYPERCUBES OF THE
C        DIFFERENCES DIFF.
C     REAL T
C        A RESIDUAL (Y(I) - MEANY)
C     REAL TA
C        A TEMPORARY VARIABLE IN THE RUNS CALCULATION.
C     REAL TK1, TK2
C        CHI-SQUARED VALUES.
C     REAL Y(N)
C        INPUT PARAMETER.  A SET OF N DATA POINTS, SORTED
C        INTO ASCENDING ORDER.
C
C
C     BEGIN STORAGE OF STATISTICS.
C
      STS(1) = N
      STS(2) = STS(1)
      STS(24) = (2.0E0*STS(1)-1.0E0)/3.0E0
      STS(25) = SQRT((16.0E0*STS(1)-29.0E0)/90.0E0)
      STS(43) = STS(42)/STS(1)
C
C     COMPUTE RESIDUALS AND STANDARD DEVIATIONS.
C
      ICI = 0
      IPLUS = 0
      IMINUS = 0
      IDRUNS = 0
      IC = 0
      DO 30 I=1,N
         T = Y(I) - STS(4)
         IF (T.LT.0.0E0) GO TO 10
         IPLUS = IPLUS + 1
         ICI = +1
         GO TO 20
   10    IMINUS = IMINUS + 1
         ICI = -1
   20    IF (IC.EQ.ICI) GO TO 30
         IC = ICI
         IDRUNS = IDRUNS + 1
   30 CONTINUE
      STS(28) = IPLUS
      STS(29) = IMINUS
      STS(31) = 1.0E0 + (2.0E0*STS(28)*STS(29)/STS(1))
      STS(32) = SQRT((2.0E0*STS(28)*STS(29)*
     +                 (2.0E0*STS(28)*STS(29) -
     +                  STS(28)-STS(29)))/
     +            ((STS(28)+STS(29))**2*(STS(1)-1.0E0)))
      STS(30) = IDRUNS
      STS(33) = 0.0E0
      IF (STS(32).NE.0.0E0)
     +   STS(33) = (STS(30)-STS(31))/STS(32)
      STS(13) = SUMD2/(STS(1)-1.0E0)
      STS(9) = SQRT(STS(13))
      STS(10) = STS(9)/SQRT(STS(1))
      IF (STS(4).NE.0.0E0)
     +   STS(14) = 100.0E0*ABS(STS(9)/STS(4))
      IF (STS(4).EQ.0.0E0) STS(14) = 0.0E0
      STS(36) = 0.0E0
      IF (SUMD2.GT.0.0E0)
     +   STS(36) = (SUMD3/STS(1))**2/((SUMD2/STS(1))**3)
      STS(37) = 0.0E0
      IF (SUMD2.GT.0.0E0)
     +   STS(37) = (SUMD4/STS(1))/((SUMD2/STS(1))**2)
      STS(40) = SUMD2
      STS(19) = (12.0E0*SUMDI)/(STS(1)*(STS(1)**2-1.0E0))
      STS(20) = (1.0E0/(STS(1)-2.0E0)*
     +             (12.0E0*(SUMD2/(STS(1)*(STS(1)**2-1.0E0)))-
     +              STS(19)**2))
      IF (STS(20).LE.0.0E0) STS(20) = 0.0E0
      STS(20) = SQRT(STS(20))
      IF (STS(20).EQ.0.0E0) STS(21) = 0.0E0
      IF (STS(20).GT.0.0E0) STS(21) = STS(19)/STS(20)
C
      STS(22) = 1.0E0 - CDFF(STS(21)*STS(21), 1.0E0, STS(1)-2.0E0)
C
C     COMPUTE NUMBER OF RUNS IN THE DATA.
C
      DIF = 0.0E0
      IRUN = 1
      TA = 0.0E0
      DO 40 I=1,N
         IF (I.GE.N) GO TO 50
         TA = Y(I+1) - Y(I)
         IF (TA.NE.0.0E0) GO TO 50
   40 CONTINUE
   50 DO 60 I=1,N
         IF (I.EQ.N) GO TO 60
         T = Y(I+1) - Y(I)
         DIF = DIF + T*T
         IF (TA*T.GE.0.0E0) GO TO 60
         TA = T
         IRUN = IRUN + 1
   60 CONTINUE
      STS(23) = IRUN
      STS(26) = DIF/(STS(1)-1.0E0)
      STS(27) = 0.0E0
      IF (STS(13).NE.0.0E0)
     +   STS(27) = STS(26)/STS(13)
      STS(41) = 0.0E0
      IF (STS(9).NE.0.0E0)
     +   STS(41) = (STS(4)*SQRT(STS(1)))/STS(9)
      STS(12) = SUMDA/STS(1)
      T = PPFT(0.975E0, N-1)
      TK1 = PPFCHS(0.975E0, N-1)
      TK2 = PPFCHS(0.025E0, N-1)
      STS(15) = STS(4) - T*STS(10)
      STS(16) = STS(4) + T*STS(10)
      STS(17) = SQRT((STS(1)-1.0E0)/TK1)*STS(9)
      STS(18) = SQRT((STS(1)-1.0E0)/TK2)*STS(9)
      RETURN
      END
*STAT2W
      SUBROUTINE STAT2W(Y, WT, N, NNZW, STS, SUMDA, SUMDI, SUMWD2,
     +   SUMD2, SUMD3, SUMD4, SUMW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES FOR A VECTOR Y THE STATISTICS THAT DO
C     NOT REQUIRE SORTING OF THE VECTOR, THAT IS, THOSE NOT COMPUTED
C     BY STAT1W.  WEIGHTS ARE USED IN THE CALCULATIONS.
C
C     THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS
C     CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTEN BY
C     SALLY PEAVY.  THE ORIGINAL ADAPTATION TO STARPAC WAS
C     DONE BY JANET DONALDSON.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMW,SUMWD2
      INTEGER
     +   N,NNZW
C
C  ARRAY ARGUMENTS
      REAL
     +   STS(53),WT(N),Y(N)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   DIF,T,TA,TK1,TK2
      INTEGER
     +   I,IC,ICI,ICOUNT,IDRUNS,IMINUS,IPLUS,IRUN,J
C
C  EXTERNAL FUNCTIONS
      REAL
     +   CDFF,PPFCHS,PPFT
      EXTERNAL CDFF,PPFCHS,PPFT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DIF
C        THE SUM OF THE DIFFERENCES BETWEEN SUCCEEDING ELEMENTS
C        IN Y.
C     INTEGER I
C        A LOOP INDEX.
C     INTEGER IC
C        PREVIOUS SIGN IN RUNS CALCULATION.
C     INTEGER ICI
C        CURRENT SIGN IN RUNS CALCULATION.
C     INTEGER ICOUNT
C        USED IN RUNS CALCULATIONS.
C     INTEGER IDRUNS
C        THE NUMBER OF RUNS.
C     INTEGER IERR
C        AN ERROR FLAG SET IN COMMON ERRCHK.
C     INTEGER IMINUS, IPLUS
C        COUNTS OF SIGNS OF DEVIATIONS.
C     INTEGER IRUN
C        THE NUMBER OF RUNS UP AND DOWN.
C     INTEGER J
C        A LOOP INDEX.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y AND WT.
C     INTEGER NNZW
C        INPUT PARAMETER.  THE NUMBER OF POSITIVE ELEMENTS IN WT.
C     REAL STS(53)
C        OUTPUT PARAMETER.  THE VECTOR OF 53 STATISTICS COMPUTED.
C     ROW STATISTIC                    ROW STATISTIC
C         1  LENGTH OF VECTOR             TESTS FOR NONRANDOMNESS
C         2  NUMBER OF NONZERO WEIGHTS    23  NUMBER OF RUNS UP AND DOWN
C        MEASURES OF LOCATION             24  EXPECTED NUMBER OF RUNS
C         3  UNWEIGHTED MEAN              25  S.D. OF NUMBER OF RUNS
C         4  WEIGHTED MEAN                26  MEAN SQR. SUCCESSIVE DIFF.
C         5  MEDIAN                       27  MEAN SQR. SUCC. DIFF./VAR.
C         6  MID-RANGE                    DEVIATIONS FROM WTD MEAN
C         7  25 P.C. UNWTD. TRIMMED MEAN  28  NUMBER OF + SIGNS
C         8  25 P.C. WTD. TRIMMED MEAN    29  NUMBER OF - SIGNS
C        MEASURES OF DISPERSION           30  NUMBER OF RUNS
C         9  STANDARD DEVIATION (S.D.)    31  EXPECTED NUMBER OF RUNS
C        10  S.D. OF MEAN                 32  S.D. OF RUNS
C        11  RANGE                        33  DIFF./S.D. OF RUNS
C        12  MEAN VARIATION               OTHER STATISTICS
C        13  VARIANCE (VAR.)              34  MINIMUM
C        14  COEFFICIENT OF VARIATION     35  MAXIMUM
C        CONFIDENCE INTERVALS             36  BETA 1
C        15  LOWER CONFIDENCE LIMIT, MEAN 37  BETA 2
C        16  UPPER CONFIDENCE LIMIT, MEAN 38  WTD. SUM OF VALUES
C        17  LOWER CONFIDENCE LIMIT, S.D. 39  WTD. SUM OF SQUARES
C        18  UPPER CONFIDENCE LIMIT, S.D. 40  WTD. SUM OF SQRD. DEVS.
C        LINEAR TREND STATISTICS          41  STUDENTS T
C        19  SLOPE                        42  WTD. SUM OF ABS. VALUES
C        20  S.D. OF SLOPE                43  WTD. AVG. ABS. VALUES
C        21  SLOPE/S.D. OF SLOPE = T      44-53 FREQ. DISTRIBUTION
C        22  PROB ( X .GT. ABS(OBS. T))
C     REAL SUMDA
C        INPUT PARAMETER.  THE SUM OF THE ABSOLUTE VALUES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMDI
C        INPUT PARAMETER.  THE SUM OF THE PRODUCTS OF I AND THE
C        ITH DIFFERENCE DIFF.
C     REAL SUMD2
C        INPUT PARAMETER.  THE SUM OF THE SQUARES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD3
C        INPUT PARAMETER.  THE SUM OF THE CUBES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD4
C        INPUT PARAMETER.  THE SUM OF THE HYPERCUBES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMW
C        INPUT PARAMETER.  THE SUM OF THE WEIGHTS VECTOR WT.
C     REAL SUMWD2
C        INPUT PARAMETER.  THE WEIGHTED SUM OF THE SQUARED
C        DIFFERENCES DIFF.
C     REAL T
C        A RESIDUAL (Y(I) - MEANY)
C     REAL TA
C        A TEMPORARY VARIABLE IN THE RUNS CALCULATION.
C     REAL TK1, TK2
C        CHI-SQUARED VALUES.
C     REAL WT(N)
C        INPUT PARAMETER.  THE VECTOR OF WEIGHTS FOR THE
C        Y OBSERVATIONS.
C     REAL Y(N)
C        INPUT PARAMETER.  A SET OF N DATA POINTS, SORTED
C        INTO ASCENDING ORDER.
C
C
C     BEGIN STORAGE OF STATISTICS.
C
      STS(1) = N
      STS(2) = NNZW
      STS(24) = (2.0E0*STS(2)-1.0E0)/3.0E0
      STS(25) = SQRT((16.0E0*STS(2)-29.0E0)/90.0E0)
      STS(43) = STS(42)/SUMW
C
C     COMPUTE RESIDUALS AND STANDARD DEVIATIONS.
C
      ICI = 0
      IPLUS = 0
      IMINUS = 0
      IDRUNS = 0
      IC = 0
      DO 30 I=1,N
         IF (WT(I).LE.0.0E0) GO TO 30
         T = Y(I) - STS(4)
         IF (T.LT.0.0E0) GO TO 10
         IPLUS = IPLUS + 1
         ICI = 1
         GO TO 20
   10    IMINUS = IMINUS + 1
         ICI = -1
   20    IF (IC.EQ.ICI) GO TO 30
         IC = ICI
         IDRUNS = IDRUNS + 1
   30 CONTINUE
      STS(28) = IPLUS
      STS(29) = IMINUS
      STS(31) = 1.0E0 + (2.0E0*STS(28)*STS(29)/STS(2))
      STS(32) =
     +   SQRT((2.0E0*STS(28)*STS(29)*(2.0E0*STS(28)*STS(29)-
     +                                     STS(28)-STS(29)))/
     +        ((STS(28)+STS(29))**2*(STS(2)-1.0E0)))
      STS(30) = IDRUNS
      STS(33) = 0.0E0
      IF (STS(32).NE.0.0E0)
     +   STS(33) = (STS(30)-STS(31))/STS(32)
      STS(13) = SUMWD2/(STS(2)-1.0E0)
      STS(9) = SQRT(STS(13))
      STS(10) = STS(9)/(SQRT(SUMW))
      IF (STS(4).NE.0.0E0)
     +   STS(14) = 100.0E0*ABS(STS(9)/STS(4))
      IF (STS(4).EQ.0.0E0) STS(14) = 0.0E0
      STS(36) = 0.0E0
      IF (SUMD2.NE.0.0E0)
     +   STS(36) = (SUMD3/STS(2))**2/((SUMD2/STS(2))**3)
      STS(37) = 0.0E0
      IF (SUMD2.NE.0.0E0)
     +   STS(37) = (SUMD4/STS(2))/((SUMD2/STS(2))**2)
      STS(40) = SUMWD2
      STS(19) = (12.0E0*SUMDI)/(STS(2)*(STS(2)**2-1.0E0))
      STS(20) = (1.0E0/(STS(2)-2.0E0)*
     +             (12.0E0*(SUMD2/(STS(2)*(STS(2)**2-1.0E0)))-
     +              STS(19)**2))
      IF (STS(20).LE.0.0E0) STS(20) = 0.0E0
      STS(20) = SQRT(STS(20))
      IF (STS(20).EQ.0.0E0) STS(21) = 0.0E0
      IF (STS(20).GT.0.0E0) STS(21) = STS(19)/STS(20)
C
      STS(22) = 1.0E0 - CDFF(STS(21)*STS(21), 1.0E0, STS(2)-2.0E0)
C
C     COMPUTE NUMBER OF RUNS IN THE DATA.
C
      DIF = 0.0E0
      IRUN = 1
      TA = 0.0E0
      DO 50 I=1,N
         IF (I.GE.N) GO TO 60
         IF (WT(I).LE.0.0E0) GO TO 50
         J = I
   40    J = J + 1
         IF (J.GE.N) GO TO 60
         IF (WT(J).LE.0.0E0) GO TO 40
         TA = Y(J) - Y(I)
         IF (TA.NE.0.0E0) GO TO 60
   50 CONTINUE
   60 ICOUNT = 0
      DO 80 I=1,N
         IF (WT(I).LE.0.0E0) GO TO 80
         ICOUNT = ICOUNT + 1
         IF (ICOUNT.GE.NNZW) GO TO 80
         J = I
   70    J = J + 1
         IF (WT(J).LE.0.0E0) GO TO 70
         T = Y(J) - Y(I)
         DIF = DIF + T*T
         IF (TA*T.GE.0.0E0) GO TO 80
         TA = T
         IRUN = IRUN + 1
   80 CONTINUE
      STS(23) = IRUN
      STS(26) = DIF/(STS(2)-1.0E0)
      STS(27) = 0.0E0
      IF (STS(13).NE.0.0E0)
     +   STS(27) = STS(26)/STS(13)
      STS(41) = 0.0E0
      IF (STS(9).NE.0.0E0)
     +   STS(41) = (STS(4)*SQRT(SUMW))/STS(9)
      STS(12) = SUMDA/STS(2)
      T = PPFT(0.975E0, NNZW-1)
      TK1 = PPFCHS(0.975E0, NNZW-1)
      TK2 = PPFCHS(0.025E0, NNZW-1)
      STS(15) = STS(4) - T*STS(10)
      STS(16) = STS(4) + T*STS(10)
      STS(17) = SQRT((STS(2)-1.0E0)/TK1)*STS(9)
      STS(18) = SQRT((STS(2)-1.0E0)/TK2)*STS(9)
      RETURN
      END
*STATER
      SUBROUTINE STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE CHECKS INPUT PARAMETERS TO THE USER
C     CALLABLE MEMBERS OF THE STAT FAMILY OF ROUTINES
C     FOR ERRORS AND REPORTS ANY THAT IT FINDS, BESIDES
C     RETURNING A FLAG INDICATING THAT ERRORS HAVE BEEN
C     FOUND.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IERR,LDSTAK,N,NNZW
      LOGICAL
     +   STACK,WTS
C
C  ARRAY ARGUMENTS
      REAL
     +   WT(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   LDSMIN,NZW
      LOGICAL
     +   HEAD,IER1,IER2,IER3
C
C  LOCAL ARRAYS
      CHARACTER
     +   LLDS(8)*1,LN(8)*1,LTHREE(8)*1,LWT(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ERVWT,LDSCMP
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 IERR
C        OUTPUT PARAMETER.  A FLAG INDICATING WHETHER OR
C        NOT AN ERROR HAS BEEN FOUND.  0 = OK, 1 = ERROR.
C     LOGICAL IER1
C        TRUE IF N .LT. 3
C     LOGICAL IER2
C        TRUE IF LDSTAK .LT. (N + 13)/2.0E0
C     LOGICAL IER3
C        TRUE IF SOME WT .LT. 0.0E0 OR NNZW .LT. 3
C     INTEGER LDSMIN
C        MINIMUM LENGTH OF FRAMEWORK AREA IN DOUBLE
C        PRECISION ELEMENTS.
C     INTEGER LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF LOCATIONS PROVIDED IN
C        THE FRAMEWORK AREA.
C     CHARACTER*1 LLDS(8), LN(8), LTHREE(8), LWT(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) FO THE VARIALBE(S) CHECKED
C        FOR ERRORS
C     INTEGER N
C        INPUT PARAMETER.  THE NUMBER OF ELEMENTS IN Y AND WT.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE
C     INTEGER NNZW
C        OUTPUT PARAMETER.  IF WTS, THEN SET EQUAL TO THE
C        NUMBER OF VALUES IN WT WHICH ARE POSITIVE.  ELSE,
C        UNDEFINED.
C     INTEGER NZW
C        THE NUMBER OF ZERO WEIGHTS.
C     LOGICAL STACK
C        A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE)
C        OR NOT (FALSE).
C     REAL WT(N)
C        INPUT PARAMETER.  THE VECTOR OF WEIGHTS CORRESPONDING
C        TO THE VECTOR Y.
C     LOGICAL WTS
C        INPUT PARAMETER.  A FLAG INDICATING WHETHER OR NOT
C        THERE IS REALLY A VECTOR WT (TRUE), OR ONLY A DUMMY PARAMETER
C        (FALSE).
C
C     INITIALIZE NAME VECTORS
C
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +  LLDS(7), LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/
      DATA     LN(1),    LN(2),    LN(3),    LN(4),    LN(5),    LN(6),
     +  LN(7), LN(8)  / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/
      DATA LTHREE(1),LTHREE(2),LTHREE(3),LTHREE(4),LTHREE(5),LTHREE(6),
     +  LTHREE(7), LTHREE(8) / 'T', 'H', 'R', 'E', 'E', ' ', ' ', ' '/
      DATA    LWT(1),   LWT(2),   LWT(3),   LWT(4),   LWT(5),   LWT(6),
     +  LWT(7), LWT(8) / 'W', 'T', ' ', ' ', ' ', ' ', ' ', ' '/
C
C     INITIALIZE ERROR FLAGS
C
      IER1 = .FALSE.
      IER2 = .FALSE.
      IER3 = .FALSE.
C
      IERR = 0
C
      HEAD = .TRUE.
C
C     CHECK TO SEE THAT THERE ARE AT LEAST THREE DATA POINTS.
C
      CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, IER1, LTHREE)
C
C     CHECK TO SEE THAT AN AMOUNT OF WORK AREA EQUAL
C     IN LENGTH TO THE REQUIREMENTS OF THE PERMUTATION
C     VECTOR WILL BE AVAILABLE.
C
      IF (STACK) THEN
         CALL LDSCMP(1, 0, N, 0, 0, 0, 'S', 0, LDSMIN)
         CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, IER2, LLDS)
      END IF
C
C     IF THERE ARE WEIGHTS
C     CHECK TO SEE THAT AT LEAST THREE DATA ITEMS HAVE NONZERO WEIGHTS.
C
      NNZW = N
      IF (WTS) THEN
         CALL ERVWT(NMSUB, LWT, WT, N, 3, HEAD, NNZW, NZW, 1, IER3,
     +              LTHREE)
      END IF
C
C     SEE IF ANY ERRORS WERE FOUND.
C
      IF (IER1 .OR. IER2 .OR. IER3) IERR = 1
      RETURN
      END
*STAT
      SUBROUTINE STAT(Y, N, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A VECTOR
C     Y, WITH NO WEIGHTS SPECIFIED.  ONE PAGE OF AUTOMATIC
C     PRINTOUT IS PRODUCED.
C
C     WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C        (EXTENSIVE REVISION OF OLDER VERSION)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1
      INTEGER
     +   IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW
      LOGICAL
     +   STACK,WTS
C
C  LOCAL ARRAYS
      REAL
     +   STS(53),WT(1)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GENI,IPRINT,SRTIR,SRTRI,STAT1,STAT2,STATER,STKCLR,STKSET,
     +   SUMBS,SUMDS,SUMID,SUMOT,SUMSS,SUMTS
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE PERCENTAGE TO BE TRIMMED OFF EACH END OF Y FOR THE
C        TRIMMED MEANS CALCULATIONS.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IDP
C        THE CODE VALUE FOR DOUBLE PRECISION FOR FRAMEWORK.
C     INTEGER IERR
C        THE CODE INDICATING WHETHER OR NOT AN ERROR HAS
C        BEEN DISCOVERED.  0 MEANS NO ERROR, NOT 0 MEANS
C        SOME ERROR EXISTS.
C     INTEGER IINT
C        THE CODE VALUE FOR INTEGER FOR FRAMEWORK
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 LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF DOUBLE PRECISION
C        ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM.
C     INTEGER LSORT
C        THE STARTING LOCATION IN ISTAK OF THE PERMUTATION
C        VECTOR.
C     INTEGER MID
C        THE INDEX OF THE (AN) ELEMENT OF Y CLOSEST TO ZERO, WHEN
C        Y HAS BEEN SORTED.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NNZW
C        NUMBER OF NONZERO WEIGHTS.
C     LOGICAL STACK
C        A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE)
C        OR NOT (FALSE).
C     REAL STS(53)
C        THE VECTOR OF THE 53 STATISTICS COMPUTED.
C     REAL SUMDA
C        THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN.
C     REAL SUMDI
C        THE SUM OF THE PRODUCTS OF THE INDICES AND THE DIFFERENCES.
C     REAL SUMD2
C        THE SUM OF THE SQUARES OF THE DIFFERENCES.
C     REAL SUMD3
C        THE SUM OF THE CUBES OF THE DIFFERENCES.
C     REAL SUMD4
C        THE SUM OF THE 4TH POWERS OF THE DIFFERENCES.
C     REAL SUMT1
C        THE SUM OF THE ALPHA TRIMMED ARRAY Y.
C     REAL WT(1)
C        THE DUMMY WEIGHTS VECTOR.
C     LOGICAL WTS
C        A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE)
C        OR NOT (FALSE).
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF DATA POINTS ON WHICH
C        THE STATISTICS ARE COMPUTED.  Y IS SORTED, BUT RESTORED
C        TO ITS ORIGINAL ORDER AFTERWARDS.
C
C
C     INITIALIZE NAME VECTORS
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'S',      'T',      'A',      'T',      ' ',      ' '/
C
      DATA ALPHA /0.25E0/
      DATA IDP /4/
      DATA IINT /2/
      DATA WTS /.FALSE./
      DATA STACK /.TRUE./
C
C     CHECK FOR ERRORS IN THE INPUT PARAMETERS
C
      CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR)
      IF (IERR.NE.0) THEN
C
C     PRINT ERROR MESSAGE.
C
         CALL IPRINT(IPRT)
         WRITE (IPRT,1000)
         RETURN
      END IF
C
C     SET UP FRAMEWORK AREA.
C
      CALL STKSET (LDSTAK, IDP)
      NALL0 = STKST(1)
C
C     SET UP LSORT, THE PERMUTATION VECTOR.
C
      LSORT = STKGET(N,IINT)
      CALL GENI(ISTAK(LSORT), N, 1, 1)
C
C     SORT THE VECTOR Y.
C
      CALL SRTIR(ISTAK(LSORT), N, Y)
C
C     COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY.
C
      CALL STAT1(Y, N, STS(5), STS(34), STS(35), STS(6),
     +   STS(11), 10, 0.0E0, 0.0E0, STS(44))
C
C     CALCULATE SUMS OF THE SORTED ARRAY.
C
      CALL SUMBS(Y, N, 1, MID, N)
      CALL SUMSS(Y, N, 1, MID, N, STS(38), STS(39), STS(42),
     +   STS(3))
      STS(4) = STS(3)
      CALL SUMTS(Y, N, ALPHA, SUMT1, STS(7))
      STS(8) = STS(7)
      CALL SUMDS(Y, N, 1, MID, N, STS(3), SUMDA, SUMD2, SUMD3, SUMD4)
C
C     RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER.
C
      CALL SRTRI(Y, N, ISTAK(LSORT))
C
C     COMPUTE REST OF STATISTICS.
C
      CALL SUMID(Y, N, STS(3), SUMDI)
      CALL STAT2(Y, N, STS, SUMDA, SUMDI, SUMD2, SUMD3, SUMD4)
      CALL SUMOT(STS, N, N, WTS)
C
C     RETURN THE VECTOR LSORT.
C
      CALL STKCLR(NALL0)
      RETURN
C
C     FORMAT STATEMENTS.
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL STAT (Y, N, LDSTAK)')
      END
*STATS
      SUBROUTINE STATS(Y, N, LDSTAK, STS, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A VECTOR
C     Y, WITH NO WEIGHTS SPECIFIED.  ONE PAGE OF AUTOMATIC
C     PRINTOUT IS PRODUCED.
C
C     WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C        (EXTENSIVE REVISION OF OLDER VERSION)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   STS(53),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1
      INTEGER
     +   IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW
      LOGICAL
     +   STACK,WTS
C
C  LOCAL ARRAYS
      REAL
     +   WT(1)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GENI,IPRINT,SRTIR,SRTRI,STAT1,STAT2,STATER,STKCLR,STKSET,
     +   SUMBS,SUMDS,SUMID,SUMOT,SUMSS,SUMTS
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE PERCENTAGE TO TRIM FROM EACH END IN THE TRIMMED
C        MEANS.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IDP
C        FRAMEWORK CODE VALUE FOR DOUBLE PRECISION NUMBERS.
C     INTEGER IERR
C        THE CODE INDICATING WHETHER OR NOT AN ERROR HAS
C        BEEN DISCOVERED.  0 MEANS NO ERROR, NOT 0 MEANS
C        SOME ERROR EXISTS.
C     INTEGER IINT
C        THE CODE VALUE FOR INTEGER FOR FRAMEWORK.
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 LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF DOUBLE PRECISION
C        ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM.
C     INTEGER LSORT
C        THE STARTING LOCATION IN ISTAK OF THE PERMUTATION
C        VECTOR.
C     INTEGER MID
C        IN THE SORTED ARRAY Y, A POINT EQUAL TO OR THE POINT
C        CLOSEST TO, ZERO.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        INPUT PARAMETER.  FLAG TO CONTROL OUTPUT.
C        0 MEANS NO OUTPUT.  OTHER VALUES MEAN OUTPUT.
C     INTEGER NNZW
C        NUMBER OF NONZERO WEIGHTS.
C     LOGICAL STACK
C        A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE)
C        OR NOT (FALSE).
C     REAL STS(53)
C        OUTPUT PARAMETER.  THE VECTOR OF THE 53 STATISTICS COMPUTED.
C     REAL SUMDA
C        THE SUM OF THE ABSOLUTE VALUES OF THE DIFFERENCES FROM
C        THE MEAN.
C     REAL SUMDI
C        THE SUM OF THE PRODUCTS OF THE INDEX AND DIFFERENCES.
C     REAL SUMD2
C        THE SUM OF THE SQUARE OF THE DIFFERENCES.
C     REAL SUMD3
C        THE SUM OF THE CUBE OF THE DIFFERENCES.
C     REAL SUMD4
C        THE SUM OF THE 4TH POWERS OF THE DIFFERENCES.
C     REAL SUMT1
C        THE TRIMMED UNWEIGHTED SIMPLE SUM OF ELEMENTS IN Y.
C     REAL WT(1)
C        THE DUMMY WEIGHTS VECTOR.
C     LOGICAL WTS
C        A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE)
C        OR NOT (FALSE).
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF DATA POINTS ON WHICH
C        THE STATISTICS ARE COMPUTED.  Y IS SORTED, BUT RESTORED
C        TO ITS ORIGINAL ORDER AFTERWARDS.
C
C
C     INITIALIZE NAME VECTORS
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'S',      'T',      'A',      'T',      'S',      ' '/
C
      DATA ALPHA /0.25E0/
      DATA IDP /4/
      DATA IINT /2/
      DATA WTS /.FALSE./
      DATA STACK /.TRUE./
C
C     CHECK FOR ERRORS IN THE INPUT PARAMETERS.
C
      CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR)
      IF (IERR.NE.0) THEN
C
C     SET UP THE OUTPUT UNIT NUMBER.
C
         CALL IPRINT(IPRT)
         WRITE (IPRT,1000)
         RETURN
      END IF
C
C     SET UP FRAMEWORK AREA
C
      CALL STKSET (LDSTAK, IDP)
      NALL0 = STKST(1)
C
C     SET UP LSORT, THE PERMUTATION VECTOR.
C
      LSORT = STKGET(N,IINT)
      CALL GENI(ISTAK(LSORT), N, 1, 1)
C
C     SORT THE VECTOR Y.
C
      CALL SRTIR(ISTAK(LSORT), N, Y)
C
C     COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY.
C
      CALL STAT1(Y, N, STS(5), STS(34), STS(35), STS(6),
     +   STS(11), 10, 0.0E0, 0.0E0, STS(44))
C
C     CALCULATE SUMS OF THE SORTED ARRAY.
C
      CALL SUMBS(Y, N, 1, MID, N)
      CALL SUMSS(Y, N, 1, MID, N, STS(38), STS(39), STS(42),
     +   STS(3))
      STS(4) = STS(3)
      CALL SUMTS(Y, N, ALPHA, SUMT1, STS(7))
      STS(8) = STS(7)
      CALL SUMDS(Y, N, 1, MID, N, STS(3), SUMDA, SUMD2, SUMD3, SUMD4)
C
C     RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER.
C
      CALL SRTRI(Y, N, ISTAK(LSORT))
C
C     COMPUTE REST OF STATISTICS.
C
      CALL SUMID(Y, N, STS(3), SUMDI)
      CALL STAT2(Y, N, STS, SUMDA, SUMDI, SUMD2, SUMD3, SUMD4)
      IF (NPRT.NE.0) CALL SUMOT(STS, N, N, WTS)
C
C     RETURN THE VECTOR LSORT.
C
      CALL STKCLR(NALL0)
      RETURN
C
C     FORMAT STATEMENTS.
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL STATS (Y, N, LDSTAK, STS, NPRT)')
      END
*STATW
      SUBROUTINE STATW(Y, WT, N, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A
C     VECTOR Y, WITH WEIGHTS SPECIFIED.  ONE PAGE OF AUTOMATIC
C     PRINTOUT IS PRODUCED.
C
C     WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C        (EXTENSIVE REVISION OF OLDER VERSION)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,N
C
C  ARRAY ARGUMENTS
      REAL
     +   WT(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,SUM1,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1,SUMW,SUMWD2,
     +   SUMWT1
      INTEGER
     +   IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW
      LOGICAL
     +   STACK,WTS
C
C  LOCAL ARRAYS
      REAL
     +   STS(53)
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GENI,IPRINT,SRTIRR,SRTRRI,STAT1W,STAT2W,STATER,STKCLR,
     +   STKSET,SUMBS,SUMIDW,SUMOT,SUMWDS,SUMWSS,SUMWTS
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE PERCENTAGE OF POINTS TO BE TRIMMED FROM EITHER END OF
C        Y IN CALCULATING THE TRIMMED MEANS.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IDP
C        FRAMEWORK CODE VALUE FOR DOUBLE PRECISION NUMBERS.
C     INTEGER IERR
C        THE CODE INDICATING WHETHER OR NOT AN ERROR HAS
C        BEEN DISCOVERED.  0 MEANS NO ERROR, NOT 0 MEANS
C        SOME ERROR EXISTS.
C     INTEGER IINT
C        THE CODE VALUE FOR INTEGER FOR FRAMEWORK.
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 LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF DOUBLE PRECISION
C        ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM.
C     INTEGER LSORT
C        THE STARTING LOCATION IN ISTAK OF THE PERMUTATION
C        VECTOR.
C     INTEGER MID
C        THE INDEX OF A ZERO ELEMENT IN THE SORTED Y, OR OF THE
C        ELEMENT CLOSEST TO ZERO.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NNZW
C        NUMBER OF NONZERO WEIGHTS.
C     LOGICAL STACK
C        A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE)
C        OR NOT (FALSE).
C     REAL STS(53)
C        THE VECTOR OF THE 53 STATISTICS COMPUTED.
C     REAL SUMDA
C        THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN.
C     REAL SUMDI
C        THE SUM OF THE PRODUCTS OF THE INDICES AND THE
C        DIFFERENCES.
C     REAL SUMD2
C        THE SUM OF THE SQUARES OF THE DIFFERENCES.
C     REAL SUMD3
C        THE SUM OF THE CUBES OF THE DIFFERENCES.
C     REAL SUMD4
C        THE SUM OF THE 4TH POWERS OF THE DIFFERENCES.
C     REAL SUMT1
C        THE SUM OF THE ALPHA TRIMMED ARRAY Y.
C     REAL SUMW
C        THE SUM OF THE WEIGHTS VECTOR WT.
C     REAL SUMWD2
C        THE WEIGHTED SUM OF THE SQUARES OF THE DIFFERENCES.
C     REAL SUMWT1
C        THE WEIGHTED SUM OF THE ALPHA TRIMMED ARRAY.
C     REAL SUM1
C        THE UNWEIGHTED SUM OF THE ELEMENTS OF Y.
C     REAL WT(N)
C        INPUT PARAMETER.  THE WEIGHTS VECTOR.
C     LOGICAL WTS
C        A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE)
C        OR NOT (FALSE).
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF DATA POINTS ON WHICH
C        THE STATISTICS ARE COMPUTED.  Y IS SORTED, BUT RESTORED
C        TO ITS ORIGINAL ORDER AFTERWARDS.
C
C
C     INITIALIZE NAME VECTORS
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'S',      'T',      'A',      'T',      'W',      ' '/
C
      DATA ALPHA /0.25E0/
      DATA IDP /4/
      DATA IINT /2/
      DATA WTS /.TRUE./
      DATA STACK /.TRUE./
C
C     CHECK FOR ERRORS IN THE INPUT PARAMETERS.
C
      CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR)
      IF (IERR.NE.0) THEN
C
C     PRINT ERROR MESSAGE.
C
         CALL IPRINT(IPRT)
         WRITE (IPRT,1000)
         RETURN
      END IF
C
C     SET UP FRAMEWORK AREA.
C
      CALL STKSET (LDSTAK, IDP)
      NALL0 = STKST(1)
C
C     SET UP LSORT, THE PERMUTATION VECTOR.
C
      LSORT = STKGET(N,IINT)
      CALL GENI(ISTAK(LSORT), N, 1, 1)
C
C     SORT THE VECTOR Y.
C
      CALL SRTIRR(ISTAK(LSORT), WT, N, Y)
C
C     COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY.
C
      CALL STAT1W(Y, WT, N, STS(5), STS(34), STS(35), STS(6),
     +   STS(11), 10, 0.0E0, 0.0E0, STS(44), NNZW)
C
C     COMPUTED VARIOUS SUMS IN THE SORTED ARRAY Y.
C
      CALL SUMBS(Y, N, 1, MID, N)
      CALL SUMWSS(Y, WT, N, 1, MID, N, NNZW, SUM1, STS(38), STS(39),
     +   STS(42), SUMW, STS(3), STS(4))
      CALL SUMWTS(Y, WT, N, NNZW, ALPHA, SUMT1, SUMWT1, STS(7),
     +   STS(8))
      CALL SUMWDS(Y, WT, N, 1, MID, N, STS(4), SUMDA, SUMWD2, SUMD2,
     +   SUMD3, SUMD4)
C
C     RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER.
C
      CALL SRTRRI(Y, WT, N, ISTAK(LSORT))
C
C     COMPUTE REST OF STATISTICS.
C
      CALL SUMIDW(Y, WT, N, STS(4), SUMDI)
      CALL STAT2W(Y, WT, N, NNZW, STS, SUMDA, SUMDI, SUMWD2, SUMD2,
     +   SUMD3, SUMD4, SUMW)
      CALL SUMOT(STS, N, NNZW, WTS)
C
C     RETURN THE VECTOR LSORT.
C
      CALL STKCLR(NALL0)
      RETURN
C
C     FORMAT STATEMENTS.
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL STATW (Y, WT, N, LDSTAK)')
      END
*STATWS
      SUBROUTINE STATWS(Y, WT, N, LDSTAK, STS, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A VECTOR
C     Y, WITH WEIGHTS SPECIFIED.  ONE PAGE OF AUTOMATIC
C     PRINTOUT IS PRODUCED.
C
C     WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C        (EXTENSIVE REVISION OF OLDER VERSION)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSTAK,N,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   STS(53),WT(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,SUM1,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1,SUMW,SUMWD2,
     +   SUMWT1
      INTEGER
     +   IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW
      LOGICAL
     +   STACK,WTS
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GENI,IPRINT,SRTIRR,SRTRRI,STAT1W,STAT2W,STATER,STKCLR,
     +   STKSET,SUMBS,SUMIDW,SUMOT,SUMWDS,SUMWSS,SUMWTS
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        THE PERCENTAGE TO BE TRIMMED FROM EACH END OF THE
C        SORTED ARRAY Y.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IDP
C        FRAMEWORK CODE VALUE FOR DOUBLE PRECISION NUMBERS.
C     INTEGER IERR
C        THE CODE INDICATING WHETHER OR NOT AN ERROR HAS
C        BEEN DISCOVERED.  0 MEANS NO ERROR, NOT 0 MEANS
C        SOME ERROR EXISTS.
C     INTEGER IINT
C        THE CODE VALUE FOR INTEGER FOR FRAMEWORK.
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 LDSTAK
C        INPUT PARAMETER.  THE NUMBER OF DOUBLE PRECISION
C        ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM.
C     INTEGER LSORT
C        THE STARTING LOCATION IN ISTAK OF THE PERMUTATION VECTOR.
C     INTEGER MID
C        THE INDEX OF A ZERO ELEMENT IN THE SORTED Y, OR OF THE
C        ELEMENT CLOSEST TO ZERO.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF Y.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE
C        WAS CALLED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        INPUT PARAMETER.  THE CODE INDICATING WHETHER PRINTOUT
C        IS DESIRED.  0 MEANS NO PRINTOUT, NOT 0 MEANS PRINTOUT.
C     INTEGER NNZW
C        NUMBER OF NONZERO WEIGHTS.
C     LOGICAL STACK
C        A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE)
C        OR NOT (FALSE).
C     REAL STS(53)
C        OUTPUT PARAMETER.  THE VECTOR OF THE 53 STATISTICS COMPUTED.
C     REAL SUMDA
C        THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN.
C     REAL SUMDI
C        THE SUM OF THE PRODUCTS OF THE INDICES AND THE
C        DIFFERENCES.
C     REAL SUMD2
C        THE SUM OF THE SQUARES OF THE DIFFERENCES.
C     REAL SUMD3
C        THE SUM OF THE CUBES OF THE DIFFERENCES.
C     REAL SUMD4
C        THE SUM OF THE 4TH POWERS OF THE DIFFERENCES.
C     REAL SUMT1
C        THE SUM OF THE ALPHA TRIMMED ARRAY Y.
C     REAL SUMW
C        THE SUM OF THE WEIGHTS VECTOR WT.
C     REAL SUMWD2
C        THE WEIGHTED SUM OF THE SQUARES OF THE DIFFERENCES.
C     REAL SUMWT1
C        THE WEIGHTED SUM OF THE ALPHA TRIMMED ARRAY.
C     REAL SUM1
C        THE SUM OF THE ELEMENTS OF X.  A DUMMY VARIABLE.
C     REAL WT(N)
C        INPUT PARAMETER.  THE WEIGHTS VECTOR.
C     LOGICAL WTS
C        A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE)
C        OR NOT (FALSE).
C     REAL Y(N)
C        INPUT PARAMETER.  THE VECTOR OF DATA POINTS ON WHICH
C        THE STATISTICS ARE COMPUTED.  Y IS SORTED, BUT RESTORED
C        TO ITS ORIGINAL ORDER AFTERWARDS.
C
C
C     INITIALIZE NAME VECTORS
C
      DATA  NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6)
     +   /       'S',      'T',      'A',      'T',      'W',      'S'/
C
      DATA ALPHA /0.25E0/
      DATA IDP /4/
      DATA IINT /2/
      DATA WTS /.TRUE./
      DATA STACK /.TRUE./
C
C     CHECK FOR ERRORS IN THE INPUT PARAMETERS.
C
      CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR)
      IF (IERR.NE.0) THEN
C
C     PRINT ERROR MESSAGE.
C
         CALL IPRINT(IPRT)
         WRITE (IPRT,1000)
         RETURN
      END IF
C
C     SET UP FRAMEWORK AREA.
C
      CALL STKSET (LDSTAK, IDP)
      NALL0 = STKST(1)
C
C     SET UP LSORT, THE PERMUTATION VECTOR.
C
      LSORT = STKGET(N,IINT)
      CALL GENI(ISTAK(LSORT), N, 1, 1)
C
C     SORT THE VECTOR Y CARRYING ALONG THE CONTENTS OF THE VECTOR
C     ISTAK(LSORT).
C
      CALL SRTIRR(ISTAK(LSORT), WT, N, Y)
C
C     COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY.
C
      CALL STAT1W(Y, WT, N, STS(5), STS(34), STS(35), STS(6),
     +   STS(11), 10, 0.0E0, 0.0E0, STS(44), NNZW)
C
C     COMPUTED VARIOUS SUMS IN THE SORTED ARRAY Y.
C
      CALL SUMBS(Y, N, 1, MID, N)
      CALL SUMWSS(Y, WT, N, 1, MID, N, NNZW, SUM1, STS(38), STS(39),
     +   STS(42), SUMW, STS(3), STS(4))
      CALL SUMWTS(Y, WT, N, NNZW, ALPHA, SUMT1, SUMWT1, STS(7),
     +   STS(8))
      CALL SUMWDS(Y, WT, N, 1, MID, N, STS(4), SUMDA, SUMWD2, SUMD2,
     +   SUMD3, SUMD4)
C
C     RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER.
C
      CALL SRTRRI(Y, WT, N, ISTAK(LSORT))
C
C     COMPUTE REST OF STATISTICS.
C
      CALL SUMIDW(Y, WT, N, STS(4), SUMDI)
      CALL STAT2W(Y, WT, N, NNZW, STS, SUMDA, SUMDI, SUMWD2, SUMD2,
     +   SUMD3, SUMD4, SUMW)
      IF (NPRT.NE.0) CALL SUMOT(STS, N, NNZW, WTS)
C
C     RETURN THE VECTOR LSORT.
C
      CALL STKCLR(NALL0)
      RETURN
C
C     FORMAT STATEMENTS.
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL STATWS (Y, WT, N, LDSTAK, STS, NPRT)')
      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     COMMENCE BODY OF ROUTINE
C
      NALLN = STKST(1)
      CALL STKREL (NALLN - NALL0)
      RETURN
      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,IPRT,LBOOK,LMAX,LNOW,LOUT,LUSED
C
C  LOCAL ARRAYS
      INTEGER
     +   ISIZE(5),ISTAK(12)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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
      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
      CALL IPRINT(IPRT)
      WRITE(IPRT, 1000)
      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
 1000 FORMAT(20H DSTAK IS TOO SHORT.)
C
      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
     +   IN,IPRT,LBOOK,LMAX,LNOW,LOUT,LUSED
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
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
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
      CALL IPRINT(IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
   30 IERR = 1
      CALL IPRINT(IPRT)
      WRITE (IPRT, 1010)
      RETURN
C
   40 IERR = 1
      CALL IPRINT(IPRT)
      WRITE (IPRT, 1020) LOUT
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (///18H ***** ERROR *****//
     +   50H DSTAK BOOKKEEPING ELEMENTS HAVE BEEN OVERWRITTEN.)
 1010 FORMAT (///18H ***** ERROR *****//
     +   52H ATTEMPT HAS BEEN MADE TO DE-ALLOCATE A NON-EXISTANT,
     +   21H ALLOCATION IN DSTAK.)
 1020 FORMAT (///18H ***** ERROR *****//
     +   35H THE POINTER FOR ALLOCATION NUMBER , I3, 9H HAS BEEN,
     +   13H OVERWRITTEN.)
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  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  REAL
      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
*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
      INTEGER
     +   IPRT
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12),ISTATS(4)
C
C  EXTERNAL SUBROUTINES
      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
C     COMMENCE BODY OF ROUTINE
C
      IF (NFACT .GT. 0 .AND. NFACT .LT. 6) GO TO 10
C
C     REPORT ERROR STATUS
C
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000) IPRT
      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
 1000 FORMAT (///18H ***** ERROR *****//
     +   24H ILLEGAL STACK STATISTIC, I5, 11H REQUESTED.)
      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
C
      STOPX = .FALSE.
      RETURN
      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
      REAL
     +   ABSTOL,RELTOL,STP,STPLOW,STPMID,STPUP
      INTEGER
     +   IXM,J,M,N,NEXMPT,NFAIL,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   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
      REAL
     +   Q
C
C  LOCAL SCALARS
      REAL
     +   FACTOR,STPNEW,TEMP
      INTEGER
     +   NCOUNT
      LOGICAL
     +   DONE,FIRST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CMPFD,ICOPY,RELCOM,SCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SIGN
C
C  COMMON BLOCKS
      COMMON /NOTOPT/Q
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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     REAL FACTOR
C        A FACTOR USED IN COMPUTING THE STEP SIZE.
C     REAL FD(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     REAL 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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL 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     REAL Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     REAL RELTOL
C        THE RELATIVE AGREEMENT TOLERANCE.
C     REAL STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD
C        DIFFERENCE APPROXIMATION TO THE DERIVATIVE.
C     REAL STPLOW
C        THE LOWER LIMIT ON THE STEP SIZE.
C     REAL STPMID
C        THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE.
C     REAL STPNEW
C        THE VALUE OF THE NEW STEP SIZE BEING TESTED.
C     REAL STPUP
C        THE UPPER LIMIT ON THE STEP SIZE.
C     REAL TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
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.0E0, PAR(J))
            FACTOR = 10.0E0
      ELSE
C
            STPNEW = STPLOW * SIGN(1.0E0, PAR(J))
            FACTOR = 0.1E0
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 SCOPY(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.0E0 .AND. ABS(STPNEW).GT.ABS(STP))
     +            .OR.
     +            (FACTOR.LT.1.0E0 .AND. ABS(STPNEW).LT.ABS(STP)))
     +            DONE = .TRUE.
          END IF
C
      IF (DONE) THEN
         RETURN
      ELSE
         GO TO 60
      END IF
C
      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
      REAL
     +   EXM
      INTEGER
     +   ISUBHD,J,LSCALE,N,NETA,NEXMPT,NPAR,NPRT
      LOGICAL
     +   HEAD,PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   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     REAL 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     REAL 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     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL 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
      RETURN
C
      END
*STPCNT
      SUBROUTINE STPCNT(XM, N, M, IXM, MDL, PAR, NPAR, STP,
     +   EXMPT, NETA, SCALE, LSCALE, NPRT, HDR, PAGE, WIDE, ISUBHD,
     +   HLFRPT, PRTFXD, IFIXED, LIFIXD)
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
      REAL
     +   EXMPT
      INTEGER
     +   ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT
      LOGICAL
     +   HLFRPT,PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),SCALE(LSCALE),STP(NPAR),XM(IXM,M)
      INTEGER
     +   IFIXED(LIFIXD)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL HDR,MDL
C
C  SCALARS IN COMMON
      REAL
     +   Q
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   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
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      INTEGER
     +   STKGET,STKST
      EXTERNAL R1MACH,STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CPYVII,ETAMDL,SETIV,STKCLR,STPMN,STPOUT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,INT,LOG10,MAX,MIN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
      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     REAL ETA
C        THE RELATIVE NOISE IN THE MODEL
C     REAL 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     REAL EXMPT
C        THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED
C        NUMERICAL DRVATIVES 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     REAL 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 STEP SIZE SELECTION
C        ROUTINE HAS ALREADY PRINTED PART OF THE INITIAL SUMMARY (TRUE)
C        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 .EQ. 1, ERRORS HAVE BEEN 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 ISTAK OF
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
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
C        IFIXED(I).EQ.0, 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 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 THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER LIFIXD
C        THE LENGTH OF THE VECTOR IFIXED.
C     INTEGER LSCALE
C        THE LENGTH 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        THE NUMBER OF STACK ALLOCATIONS ON ENTRY.
C     INTEGER NDD
C        THE NUMBER OF DECIMAL DIGITS CARRIED FOR A REAL
C        NUMBERS.
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 USER SUPPLIED 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
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 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 A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
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 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     REAL Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL SCL
C        THE ACTUAL TYPICAL SIZE USED.
C     REAL STP(NPAR)
C        THE SELECTED STEP SIZES.
C     REAL 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     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C
      NALL0 = STKST(1)
C
      FPLRS = R1MACH(4)
      IFP = 3
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(MAX(N,NPAR), IFP)
      FD = STKGET(N, IFP)
      FDLAST = STKGET(N, IFP)
      FDSAVE = STKGET(N, IFP)
      PV = STKGET(N, IFP)
      PVMCD = STKGET(N, IFP)
      PVNEW = STKGET(N, IFP)
      PVPCD = STKGET(N, IFP)
      PVSTP = STKGET(N, IFP)
      PVTEMP = STKGET(N, IFP)
C
      IF (IERR .EQ. 1) RETURN
C
      PARTMP = CD
C
C     SET UP IFIXD
C
      IF (IFIXED(1).LT.0) THEN
         CALL SETIV(ISTAK(IFIXD), NPAR, 0)
      ELSE
         CALL CPYVII(NPAR, IFIXED, 1, ISTAK(IFIXD), 1)
      END IF
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.0E0 ** (-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.25E0), 0.01E0)
C
      EXM = EXMPT
      IF ((EXM.LT.0.0E0) .OR. (EXM.GT.1.0E0)) EXM = 0.10E0
      NEXMPT = EXM * N
      IF (EXM .NE. 0.0E0) 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
         IF (ISTAK(IFIXD-1+J).EQ.0) THEN
            IF (SCALE(1).LE.0.0E0) THEN
               IF (PAR(J).EQ.0.0E0) THEN
                  SCL = 1.0E0
               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
         ELSE
            STP(J) = 0.0
         END IF
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))
         NFAILJ = NFAILJ + 1
  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
*STPDRV
      SUBROUTINE STPDRV(NMSUB, XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK,
     +   STP, NETA, EXMPT, SCALE, LSCALE, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE DRIVER ROUTINE FOR SELECTING STEP SIZES
C     TO BE USED IN COMPUTING FORWARD DIFFERENCE QUOTIENT ESTIMATES
C     OF THE NUMERICAL DERIVATIVES.
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
      REAL
     +   EXMPT
      INTEGER
     +   IXM,LDSTAK,LSCALE,M,N,NETA,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),SCALE(*),STP(*),XM(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   ISUBHD,LIFIXD
      LOGICAL
     +   HLFRPT,PAGE,PRTFXD,WIDE
C
C  LOCAL ARRAYS
      INTEGER
     +   IFIXED(1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL STKSET,STPCNT,STPER,STPHDR
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL EXMPT
C        THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED
C        NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXCEPTED
C        FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA.
C     LOGICAL HLFRPT
C        THE VARIABLE WHICH INDICATES WHETHER THE STEP SIZE SELECTION
C        ROUTINE HAS ALREADY PRINTED PART OF THE INITIAL SUMMARY (TRUE)
C        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 .EQ. 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.  IF
C        IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED.  IF
C        IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LIFIXD
C        THE LENGTH OF THE VECTOR IFIXED.
C     INTEGER LSCALE
C        THE LENGTH 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 N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
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 A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
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     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C     REAL STP(NPAR)
C        THE SELECTED STEP SIZES.
C     EXTERNAL STPHDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE ARRAY
C
C
C     PERFORM ERROR CHECKING
C
      CALL STPER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE)
C
      IF (IERR.NE.0) RETURN
C
      CALL STKSET(LDSTAK, 4)
C
      PAGE = .FALSE.
      WIDE = .TRUE.
      ISUBHD = 0
C
      PRTFXD = .FALSE.
      IFIXED(1) = -1
      LIFIXD = 1
C
C     PASS CONTROL OF STEP SIZE SELECTION TO SUBROUTINE STPCNT
C
      CALL STPCNT(XM, N, M, IXM, MDL, PAR, NPAR, STP, EXMPT, NETA,
     +   SCALE, LSCALE, NPRT, STPHDR, PAGE, WIDE, ISUBHD, HLFRPT,
     +   PRTFXD, IFIXED, LIFIXD)
C
      RETURN
C
      END
*STPER
      SUBROUTINE STPER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR STEP SIZE SELECTION
C     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
     +   IXM,LDSTAK,LSCALE,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   SCALE(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,LDSMIN,NV
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERROR(10)
      CHARACTER
     +   LIXM(8)*1,LLDS(8)*1,LM(8)*1,LN(8)*1,LNPAR(8)*1,
     +   LONE(8)*1,LSCL(8)*1,LZERO(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,ERVGT,LDSCMP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR(10)
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 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 WERE DETECTED.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
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 LIXM(8), LLDS(8), LM(8), LN(8), LNPAR(8), LONE(8),
C    +            LSCL(8), LZERO(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER LSCALE
C        THE LENGTH OF VECTOR SCALE.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND.
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C
C     SET UP NAME ARRAYS
C
      DATA LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6),
     +   LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      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) /' ',' ','O','N','E',' ',' ',
     +   ' '/
      DATA LSCL(1), LSCL(2), LSCL(3), LSCL(4), LSCL(5),
     +   LSCL(6), LSCL(7), LSCL(8) /'S','C','A','L','E',' ',' ',
     +   ' '/
      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,10
         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, LM, M, 1, 2, HEAD, ERROR(2), LONE)
C
      CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(3), LN)
C
      CALL EISGE(NMSUB, LNPAR, NPAR, 1, 2, HEAD, ERROR(4), LONE)
C
      CALL LDSCMP(14, 0, 2*(N+NPAR), 0, 0, 0, 'S', 9*N + MAX(N,NPAR),
     +            LDSMIN)
C
      IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(4)))
     +   CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(5),
     +   LLDS)
C
      CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 0, HEAD, 6, NV,
     +   ERROR(9), LZERO)
C
C
      DO 20 I=1,10
         IF (ERROR(I)) GO TO 30
   20 CONTINUE
      RETURN
C
   30 CONTINUE
      IERR = 1
      RETURN
C
      END
*STPHDR
      SUBROUTINE STPHDR(PAGE, WIDE, ISUBHD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE
C     STEP SIZE SELECTION 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
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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        FULL WIDTH (TRUE) OR NOT (FALSE).
C
      CALL IPRINT(IPRT)
      IF (PAGE) WRITE (IPRT, 1020)
      CALL VERSP(WIDE)
      IF (PAGE) WRITE (IPRT,1000)
      IF (.NOT.PAGE) WRITE (IPRT,1010)
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 WRITE (IPRT, 1030)
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT (32H+DERIVATIVE STEP SIZE SELECTION,,
     +   10H CONTINUED)
 1010 FORMAT ('+', 34(1H*)/ 35H * DERIVATIVE STEP SIZE SELECTION */
     +   1X, 34(1H*))
 1020 FORMAT ('1')
 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-'))
      END
*STPLS1
      SUBROUTINE STPLS1(N, M, IXM, PAR, NPAR, NETA, EXMPT, SCALE, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE
C     ROUTINES IN THE (LEAST SQUARES) STEP SIZE SELECTION FAMILY.
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
      REAL
     +   EXMPT
      INTEGER
     +   IXM,M,N,NETA,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(10),SCALE(10)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL 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 IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NETA
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     REAL PAR(10)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL SCALE(10)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C
      PAR(1) = 0.0E0
      PAR(2) = 3.125E0
      PAR(3) = 1.0E0
      PAR(4) = 2.0E0
C
      N = 101
      M = 1
      IXM = 200
      NPAR = 4
      DO 10 I=1,10
         SCALE(I) = 1.0E0
   10 CONTINUE
      NETA = 0
      EXMPT = 0.0E0
      NPRT = 1
C
      RETURN
C
      END
*STPLS2
      SUBROUTINE STPLS2(NPAR, STP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE
C     ROUTINES IN THE (LEAST SQUARES) STEP SIZE SELECTION FAMILY.
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
     +   NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   STP(NPAR)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
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 WERE DETECTED.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     REAL STP(NPAR)
C        THE STEP SIZE ARRAY.
C
      DO 10 I=1,NPAR
         STP(I) = -1.0E0
   10 CONTINUE
C
      IERR = -1
C
      RETURN
C
      END
*STPLSC
      SUBROUTINE STPLSC(XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP,
     +   NETA, EXMPT, SCALE, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR SELECTING STEP SIZES
C     TO BE USED IN COMPUTING FORWARD DIFFERENCE QUOTIENT ESTIMATES
C     OF THE NUMERICAL DERIVATIVES FOR THE NONLINEAR LEAST SQUARES
C     ROUTINES (LONG CALL).
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
      REAL
     +   EXMPT
      INTEGER
     +   IXM,LDSTAK,M,N,NETA,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),SCALE(*),STP(*),XM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,LSCALE
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,STPDRV
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL 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 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 WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LSCALE
C        THE LENGTH 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 N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE
C        PARAMETERS ARE STORED.
C     REAL SCALE(NPAR)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL STP(NPAR)
C        THE SELECTED STEP SIZES.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE ARRAY
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'S','T','P','L','S','C'/
C
C     SET LENGTH OF VECTOR SCALE.
C
      LSCALE = NPAR
C
C     PASS CONTROL TO STEP SIZE SELECTION DRIVER
C
      CALL STPDRV(NMSUB, XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP,
     +   NETA, EXMPT, SCALE, LSCALE, NPRT)
C
      IF (IERR.NE.1) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL STPLSC (XM, N, M, IXM, NLSMDL, PAR, NPAR, LDSTAK,',
     + ' STP,'/
     + '      +             NETA, EXMPT, SCALE, NPRT)')
      END
*STPLS
      SUBROUTINE STPLS(XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR SELECTING STEP SIZES
C     TO BE USED IN COMPUTING FORWARD DIFFERENCE QUOTIENT ESTIMATES
C     OF THE NUMERICAL DERIVATIVES FOR THE NONLINEAR LEAST SQUARES
C     ROUTINES (SHORT CALL).
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,LDSTAK,M,N,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(*),STP(*),XM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   EXMPT
      INTEGER
     +   IPRT,LSCALE,NETA,NPRT
C
C  LOCAL ARRAYS
      REAL
     +   SCALE(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,STPDRV
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL EXMPT
C        THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED
C        NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXCEPTED
C        FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA.
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 WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LSCALE
C        THE LENGTH 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 N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING
C        SUBROUTINES.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE
C        PARAMETERS ARE STORED.
C     REAL SCALE(1)
C        A DUMMY VECTOR USED TO DESIGNATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL STP(NPAR)
C        THE SELECTED STEP SIZES.
C     REAL XM(IXM,M)
C        THE INDEPENDENT VARIABLE ARRAY
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'S','T','P','L','S',' '/
C
C     SET UP DEFAULT VALUES
C
      EXMPT = 0.1E0
      NETA = 0
      SCALE(1) = 0.0E0
      LSCALE = 1
      NPRT = 1
C
C     PASS CONTROL TO STEP SIZE SELECTION DRIVER
C
      CALL STPDRV(NMSUB, XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP,
     +   NETA, EXMPT, SCALE, LSCALE, NPRT)
C
      IF (IERR.NE.1) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL STPLS (XM, N, M, IXM, NLSMDL, PAR, NPAR, LDSTAK,',
     +   ' STP)')
      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
      REAL
     +   ETA,RELTOL,SCALE,STP
      INTEGER
     +   IXM,J,M,N,NEXMPT,NFAIL,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   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
      REAL
     +   Q
C
C  LOCAL SCALARS
      REAL
     +   ABSTOL,CURVE,ETA3,FPLRS,PARMX,PVMEAN,PVTYP,STPCD,STPLOW,
     +   STPMID,STPUP,TAUABS,TEMP,THIRD
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      REAL
     +   R1MACH
      EXTERNAL R1MACH
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     REAL ABSTOL
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     REAL CD(N)
C        THE CENTRAL DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
C     REAL CURVE
C        A MEASURE OF THE CURVATURE OF THE MODEL.
C     REAL ETA
C        THE RELATIVE NOISE IN THE MODEL
C     REAL ETA3
C        THE CUBE ROOT OF ETA.
C     REAL FD(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     REAL 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     REAL 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     REAL 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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE
C        TYPICAL VALUE OF THAT PARAMETER
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL 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     REAL PVMEAN
C        THE MEAN OF A FUNCTION OF THE PREDICTED VALUES.
C     REAL 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     REAL 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     REAL 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     REAL PVTEMP(N)
C        A TEMPORARY STORAGE VECTOR FOR PREDICTED VALUES.
C     REAL PVTYP
C        THE TYPICAL SIZE OF THE PREDICTED VALUES OF THE MODEL.
C     REAL Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     REAL SCALE
C        THE TYPICAL SIZE OF THE JTH PARAMETER.
C     REAL STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD
C        DIFFERENCE APPROXIMATION TO THE DERIVATIVE.
C     REAL STPCD
C        THE STEP SIZE USED FOR THE CENTRAL DIFFERENCE QUOTIENT.
C     REAL STPLOW
C        THE LOWER LIMIT ON THE STEP SIZE.
C     REAL STPMID
C        THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE.
C     REAL STPUP
C        THE UPPER LIMIT ON THE STEP SIZE.
C     REAL RELTOL
C        THE RELATIVE AGREEMENT TOLERANCE.
C     REAL TAUABS
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     REAL TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     REAL THIRD
C        THE VALUE ONE THIRD.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
      FPLRS = R1MACH(4)
C
C     SET VARIOUS PARAMETERS NECESSARY FOR COMPUTING THE
C     OPTIMUM STEP SIZE
C
      THIRD = 1.0E0 / 3.0E0
C
      ETA3 = ETA ** THIRD
C
      write ( *, * ) 'DEBUG: FPLRS = ', fplrs
      write ( *, * ) 'DEBUG: STPMN: PAR(J) = ', par(j)
      write ( *, * ) 'DEBUG: STPMN: SCALE = ', scale
      PARMX = MAX(ABS(PAR(J)), ABS(SCALE))
      IF (PARMX .EQ. 0.0E0) PARMX = 1.0E0
C
      STPCD = ((3.0E0 ** THIRD) * ETA3 * PARMX * SIGN(1.0E0, 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.0E0) THEN
            IF (PV(I).EQ.0.0E0) 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.0E0) THEN
            IF (PV(I).EQ.0.0E0) 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.0E0)
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.0E0) THEN
         STP = PARMX * SIGN(1.0E0, PAR(J))
      ELSE
         STP = (2.0E0 * SQRT(ETA) * SQRT(PVTYP) / SQRT(CURVE)) *
     +         SIGN(1.0E0,PAR(J))
      END IF
C
      IF (ABS(STP).GT.PARMX) STP = PARMX * SIGN(1.0E0,PAR(J))
C
      Q = STP + PAR(J)
      STP = Q - PAR(J)
C
      IF (STP.EQ.0.0E0) THEN
         STP = FPLRS * PAR(J)
         IF (STP.EQ.0.0E0) STP = FPLRS
C
   30    CONTINUE
         Q = STP + PAR(J)
         STP = Q - PAR(J)
C
         IF (STP.EQ.0.0E0) THEN
            STP = 2.0E0 * STP
            GO TO 30
         END IF
      END IF
C
C     COMPUTE THE ABSOLUTE TOLERANCES
C
      ABSTOL = 10.0E0 * ETA * PVTYP
C
      TAUABS = 2.0E0 * SQRT(ETA) * SQRT(PVTYP)
      IF (CURVE .NE. 0.0E0) 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.0E0*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
      write ( *, * ) 'DEBUG: STPMN: RELTOL = ', reltol
      write ( *, * ) 'DEBUG: STPMN: ABSTOL = ', abstol

      CALL RELCOM(N, FD, CD, RELTOL, ABSTOL, NFAIL, IFAIL)

      write ( *, * ) 'DEBUG: STPMN: NFAIL = ', nfail
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
      write ( *, * ) 'DEBUG: STPMN: STP=',stp, ' PARMX = ', parmx
      STP = ABS(STP) / PARMX
C
      RETURN
C
      END
*STPOUT
      SUBROUTINE STPOUT(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 SUBROUTINE PRINTS THE RESULTS OF THE STEP SIZE SELECTING
C     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
      REAL
     +   EXM
      INTEGER
     +   ISUBHD,J,LSCALE,N,NETA,NEXMPT,NPAR,NPRT
      LOGICAL
     +   HEAD,PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      REAL
     +   PAR(NPAR),SCALE(LSCALE),STP(NPAR)
      INTEGER
     +   IFAIL(N),IFIXD(NPAR),NFAIL(NPAR)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL HDR
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT,K,NFLABS,NK,NPERL
      LOGICAL
     +   SAMELN
      CHARACTER
     +   BLANK*1,C*1,F*1,PLUS*1
C
C  LOCAL ARRAYS
      INTEGER
     +   INDEX(25)
      CHARACTER
     +   FIXED(3)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FIXPRT,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC IABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER*1 BLANK
C        THE CHARACTER BLANK.
C     CHARACTER*1 C
C        THE CHARACTER FLAG INDICATING HIGH CURVATURE.
C     REAL 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     CHARACTER*1 F
C        THE CHARACTER FLAG INDICATING NUMBER OF OBSERVATIONS
C        FAILING SELECTION CRITERIA EXCEEDED EXEMPTED NUMBER.
C     CHARACTER*1 FIXED(3)
C        THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT.
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 I
C        AN INDEX VARIABLE.
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 INDEX(25)
C        THE ROW NUMBERS OF OBSERVATIONS FOR WHICH THE STEP SIZE
C        SELECTED FAILED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
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 J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER K
C        AN INDEX VARIABLE.
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 NFLABS
C        THE ABSOLUTE VALUE OF NFAIL.
C     INTEGER NK
C        AN INDEX VARIABLE.
C     INTEGER NPERL
C        THE NUMBER OF OBSERVATIONS TO BE PRINTED PER LINE.
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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE
C        PARAMETERS ARE STORED.
C     CHARACTER*1 PLUS
C        THE CHARACTER PLUS.
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     LOGICAL SAMELN
C        AN INDICATOR VALUE TO DESIGNATE WHETHER THE LINE IS TO BE
C        PRINTED ON THE SAME LINE AS THE PREVIOUS LINE PRINTED (TRUE)
C        OR NOT (FALSE).
C     REAL SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     REAL 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
      DATA BLANK /' '/, PLUS /'+'/
      CALL IPRINT(IPRT)
C
C     INITIALIZE ARRAY FIXED
C
      DO 10 K=1,3
         FIXED(K) = BLANK
   10 CONTINUE
C
      IF (HEAD) THEN
C
C     PRINT HEADING
C
         HEAD = .FALSE.
C
         CALL HDR(PAGE, WIDE, ISUBHD)
         IF (PRTFXD) THEN
            WRITE (IPRT,1000)
         ELSE
            WRITE (IPRT,1010)
         END IF
C
C     PRINT INFORMATION OTHERWISE SUPPRESSED BY PRINT CONTROL
C
         DO 20 I=1,J-1
            IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED)
            IF (IFIXD(I).EQ.0) THEN
               F = BLANK
               C = BLANK
               NFLABS = IABS(NFAIL(I))
               IF (NFLABS.GT.NEXMPT) F = PLUS
               IF (NFAIL(I).LT.0) C = PLUS
               IF (SCALE(1).GT.0.0E0) THEN
                  WRITE (IPRT,1020) I, (FIXED(K),K=1,3), PAR(I),
     +                              SCALE(I),
     +                              STP(I), NFLABS, F, C
               ELSE
                  WRITE (IPRT,1040) I, (FIXED(K),K=1,3), PAR(I),
     +                              STP(I), NFLABS, F, C
               END IF
               IF (NFLABS.GT.NEXMPT) WRITE (IPRT,1030)
            ELSE
               WRITE (IPRT,1045) I, (FIXED(K),K=1,3), PAR(I)
            END IF
   20    CONTINUE
      END IF
C
C     PRINT INFORMATION FOR CURRENT PARAMETER
C
      I = J
      IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED)
      IF (IFIXD(I).EQ.0) THEN
         F = BLANK
         C = BLANK
         NFLABS = IABS(NFAIL(I))
         IF (NFLABS.GT.NEXMPT) F = PLUS
         IF (NFAIL(I).LT.0) C = PLUS
         IF (SCALE(1).GT.0.0E0) THEN
            WRITE (IPRT,1020) I, (FIXED(K),K=1,3), PAR(I),
     +                        SCALE(I),
     +                        STP(I), NFLABS, F, C
         ELSE
            WRITE (IPRT,1040) I, (FIXED(K),K=1,3), PAR(I),
     +                        STP(I), NFLABS, F, C
         END IF
         IF (NFLABS.GE.1) THEN
            IF ((NPRT.EQ.0) .AND. (NFLABS.LE.NEXMPT)) THEN
               WRITE (IPRT,1030)
            ELSE
C
C     PRINT ROW NUMBERS
C
               NPERL = 7
C
               SAMELN = .TRUE.
               NK = 0
               DO 60 I=1,N
                  IF (IFAIL(I).EQ.0) GO TO 60
                  NK = NK + 1
                  INDEX(NK) = I
                  IF (NK.LT.NPERL) GO TO 60
                  IF (SAMELN) THEN
                     WRITE (IPRT,1050) (INDEX(K),K=1,NK)
                  ELSE
                     WRITE (IPRT,1060) (INDEX(K),K=1,NK)
                  END IF
                  SAMELN = .FALSE.
                  NK = 0
   60          CONTINUE
               IF (SAMELN) THEN
                  WRITE (IPRT,1050) (INDEX(K),K=1,NK)
               ELSE
                  WRITE (IPRT,1060) (INDEX(K),K=1,NK)
               END IF
            END IF
         END IF
      ELSE
         WRITE (IPRT,1045) I, (FIXED(K),K=1,3), PAR(I)
      END IF
      IF (J.LT.NPAR) RETURN
C
C     PRINT FINAL NOTES AND SUMMARY
C
      WRITE (IPRT,1070)
      IF (NPRT.NE.0) GO TO 100
      DO 90 I=1,NPAR
         IF (IFIXD(I).EQ.0) THEN
            IF (IABS(NFAIL(I)).GT.NEXMPT) GO TO 90
            WRITE (IPRT,1080)
            GO TO 100
         END IF
   90 CONTINUE
C
  100 CONTINUE
C
C     PRINT CONTROL VALUES USED.
C
      WRITE (IPRT,1090) NETA
      WRITE (IPRT,1100) EXM
      WRITE (IPRT,1110) NEXMPT
      WRITE (IPRT,1120) N
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (//50X, 13HSTEP SIZE FOR, 4X, 25HOBSERVATIONS FAILING STEP,
     +   24H SIZE SELECTION CRITERIA/50X, 13HAPPROXIMATING, 21X, 1H*/7X,
     +   24HPARAMETER STARTING VALUE, 6X, 5HSCALE, 10X, 10HDERIVATIVE,
     +   7X, 5HCOUNT, 5X, 5HNOTES, 5X, 10HROW NUMBER/1X, 5HINDEX, 2X,
     +   5HFIXED, 6X, 5H(PAR), 12X, 7H(SCALE), 11X, 5H(STP), 21X, 3HF C/
     +   )
 1010 FORMAT (//50X, 13HSTEP SIZE FOR, 4X, 25HOBSERVATIONS FAILING STEP,
     +   24H SIZE SELECTION CRITERIA/18X, 9HPARAMETER, 23X, 9HAPPROXIMA,
     +   4HTING, 21X, 1H*/16X, 14HSTARTING VALUE, 7X, 5HSCALE, 10X,
     +   10HDERIVATIVE, 7X, 5HCOUNT, 5X, 5HNOTES, 5X, 13HROW NUMBER(S)/
     +   1X, 5HINDEX, 13X, 5H(PAR), 12X, 7H(SCALE), 11X, 5H(STP), 21X,
     +   3HF C/)
 1020 FORMAT (1X, I3, 5X, 3A1, 3G17.8, 5X, I5, 7X, A1, 1X, A1)
 1030 FORMAT ('+', 89X, 2H**)
 1040 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 3X, G17.8, 5X, I5,
     +   7X, A1, 1X, A1)
 1045 FORMAT (1X, I3, 5X, 3A1, G17.8, 9X, '---', 14X, '---',
     +        14X, '-')
 1050 FORMAT ('+', 86X, 7I5)
 1060 FORMAT (87X, 7I5)
 1070 FORMAT (//1X, 36H*  NOTES.  A PLUS (+) IN THE COLUMNS, 8H HEADED ,
     +   33HF OR C HAS THE FOLLOWING MEANING.//4X, 17HF - NUMBER OF OBS,
     +   27HERVATIONS FAILING STEP SIZE, 27H SELECTION CRITERIA EXCEEDS/
     +   8X, 29HNUMBER OF EXEMPTIONS ALLOWED.//4X, 17HC - HIGH CURVATUR,
     +   30HE IN THE MODEL IS SUSPECTED AS, 13H THE CAUSE OF/8X,
     +   19HALL FAILURES NOTED.)
 1080 FORMAT (//46H ** ROW NUMBERS ARE ONLY LISTED WHEN NUMBER OF,
     +   26H OBSERVATIONS FAILING STEP/4X, 25HSIZE SELECTION CRITERIA E,
     +   27HXCEEDS NUMBER OF EXEMPTIONS, 9H ALLOWED.)
 1090 FORMAT (/43H NUMBER OF RELIABLE DIGITS IN MODEL RESULTS, 25X,
     +   6H(NETA), 1X, I5)
 1100 FORMAT (/41H PROPORTION OF OBSERVATIONS EXEMPTED FROM, 8H SELECTI,
     +   11HON CRITERIA, 7X, 7H(EXMPT), 2X, F6.4)
 1110 FORMAT (/37H NUMBER OF OBSERVATIONS EXEMPTED FROM, 11H SELECTION ,
     +   8HCRITERIA, 19X, I5)
 1120 FORMAT (/23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5)
      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
      REAL
     +   ABSTOL,ETA3,RELTOL,STP,STPLOW,STPMID,STPUP,TAUABS
      INTEGER
     +   IXM,J,M,N,NEXMPT,NFAIL,NPAR
C
C  ARRAY ARGUMENTS
      REAL
     +   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
      REAL
     +   Q
C
C  LOCAL SCALARS
      REAL
     +   FACTOR,STP1,STP2,STPNEW,TEMP
      INTEGER
     +   NCOUNT
      LOGICAL
     +   FAIL,FIRST,FORWRD,HICURV,SUCCES
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ABSCOM,CMPFD,ICOPY,RELCOM,SCOPY,STPADJ
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C  COMMON BLOCKS
      COMMON /NOTOPT/Q
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ABSTOL
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     REAL ETA3
C        THE CUBE ROOT OF THE RELATIVE NOISE IN THE MODEL
C     REAL 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     REAL FD(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     REAL 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     REAL 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     REAL PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     REAL PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     REAL 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     REAL Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     REAL STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD
C        DIFFERENCE APPROXIMATION TO THE DERIVATIVE.
C     REAL STPLOW
C        THE LOWER LIMIT ON THE STEP SIZE.
C     REAL STPMID
C        THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE.
C     REAL STPNEW
C        THE VALUE OF THE NEW STEP SIZE BEING TESTED.
C     REAL STPUP
C        THE UPPER LIMIT ON THE STEP SIZE.
C     REAL 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     REAL RELTOL
C        THE RELATIVE AGREEMENT TOLERANCE.
C     REAL TAUABS
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     REAL TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     REAL XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
      CALL SCOPY(N, FD, 1, FDSAVE, 1)
C
      FACTOR = 10.0E0
      IF (ABS(STP) .GT. STPMID) FACTOR = 0.1E0
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 SCOPY(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.0E0 .AND. ABS(STPNEW).GT.STPUP) .OR.
     +          (FACTOR.LT.1.0E0 .AND. ABS(STPNEW).LT.STPLOW)) THEN
                  IF (FORWRD) THEN
                        FORWRD = .FALSE.
                        FACTOR = 1.0E0 / FACTOR
                        STPNEW = STP * FACTOR
                        Q = STPNEW + PAR(J)
                        STPNEW = Q - PAR(J)
                        CALL SCOPY(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
*STRCO
      SUBROUTINE STRCO(T,LDT,N,RCOND,Z,JOB)
C***BEGIN PROLOGUE  STRCO
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A3
C***KEYWORDS  CONDITION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX,TRIANGULAR
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  ESTIMATES THE CONDITION OF A REAL TRIANGULAR MATRIX.
C***DESCRIPTION
C     STRCO ESTIMATES THE CONDITION OF A REAL TRIANGULAR MATRIX.
C     ON ENTRY
C        T       REAL(LDT,N)
C                T CONTAINS THE TRIANGULAR MATRIX.  THE ZERO
C                ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND
C                THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE
C                USED TO STORE OTHER INFORMATION.
C        LDT     INTEGER
C                LDT IS THE LEADING DIMENSION OF THE ARRAY T.
C        N       INTEGER
C                N IS THE ORDER OF THE SYSTEM.
C        JOB     INTEGER
C                = 0         T  IS LOWER TRIANGULAR.
C                = NONZERO   T  IS UPPER TRIANGULAR.
C     ON RETURN
C        RCOND   REAL
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  T .
C                FOR THE SYSTEM  T*X = B , RELATIVE PERTURBATIONS
C                IN  T  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  T  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C        Z       REAL(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  T  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SASUM,SAXPY,SSCAL
C***END PROLOGUE  STRCO

C...SCALAR ARGUMENTS
      REAL RCOND
      INTEGER
     +   JOB,LDT,N

C...ARRAY ARGUMENTS
      REAL T(LDT,*),Z(*)

C...LOCAL SCALARS
      REAL EK,S,SM,TNORM,W,WK,WKM,YNORM
      INTEGER
     +   I1,J,J1,J2,K,KK,L
      LOGICAL
     +   LOWER

C...EXTERNAL FUNCTIONS
      REAL SASUM
      EXTERNAL
     +   SASUM

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   SAXPY,SSCAL

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,AMAX1,SIGN


C***FIRST EXECUTABLE STATEMENT  STRCO


      LOWER = JOB .EQ. 0

C     COMPUTE 1-NORM OF T

      TNORM = 0.0E0
      DO 10 J = 1, N
         L = J
         IF (LOWER) L = N + 1 - J
         I1 = 1
         IF (LOWER) I1 = J
         TNORM = AMAX1(TNORM,SASUM(L,T(I1,J),1))
   10 CONTINUE

C     RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  T*Z = Y  AND  TRANS(T)*Y = E .
C     TRANS(T)  IS THE TRANSPOSE OF T .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF Y .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.

C     SOLVE TRANS(T)*Y = E

      EK = 1.0E0
      DO 20 J = 1, N
         Z(J) = 0.0E0
   20 CONTINUE
      DO 100 KK = 1, N
         K = KK
         IF (LOWER) K = N + 1 - KK
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K))
         IF (ABS(EK-Z(K)) .LE. ABS(T(K,K))) GO TO 30
            S = ABS(T(K,K))/ABS(EK-Z(K))
            CALL SSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (T(K,K) .EQ. 0.0E0) GO TO 40
            WK = WK/T(K,K)
            WKM = WKM/T(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0E0
            WKM = 1.0E0
   50    CONTINUE
         IF (KK .EQ. N) GO TO 90
            J1 = K + 1
            IF (LOWER) J1 = 1
            J2 = N
            IF (LOWER) J2 = K - 1
            DO 60 J = J1, J2
               SM = SM + ABS(Z(J)+WKM*T(K,J))
               Z(J) = Z(J) + WK*T(K,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               W = WKM - WK
               WK = WKM
               DO 70 J = J1, J2
                  Z(J) = Z(J) + W*T(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)

      YNORM = 1.0E0

C     SOLVE T*Z = Y

      DO 130 KK = 1, N
         K = N + 1 - KK
         IF (LOWER) K = KK
         IF (ABS(Z(K)) .LE. ABS(T(K,K))) GO TO 110
            S = ABS(T(K,K))/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  110    CONTINUE
         IF (T(K,K) .NE. 0.0E0) Z(K) = Z(K)/T(K,K)
         IF (T(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         I1 = 1
         IF (LOWER) I1 = K + 1
         IF (KK .GE. N) GO TO 120
            W = -Z(K)
            CALL SAXPY(N-KK,W,T(I1,K),1,Z(I1),1)
  120    CONTINUE
  130 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM

      IF (TNORM .NE. 0.0E0) RCOND = YNORM/TNORM
      IF (TNORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
*STRDI
      SUBROUTINE STRDI(T,LDT,N,DET,JOB,INFO)
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER INFO,JOB,LDT,N
C
C  ARRAY ARGUMENTS
      REAL DET(2),T(LDT,*)
C
C  LOCAL SCALARS
      REAL TEMP,TEN
      INTEGER I,J,K,KB,KM1,KP1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SAXPY,SSCAL
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MOD
C
C
C     STRDI COMPUTES THE DETERMINANT AND INVERSE OF A REAL
C     TRIANGULAR MATRIX.
C
C     ON ENTRY
C
C        T       REAL(LDT,N)
C                T CONTAINS THE TRIANGULAR MATRIX. THE ZERO
C                ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND
C                THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE
C                USED TO STORE OTHER INFORMATION.
C
C        LDT     INTEGER
C                LDT IS THE LEADING DIMENSION OF THE ARRAY T.
C
C        N       INTEGER
C                N IS THE ORDER OF THE SYSTEM.
C
C        JOB     INTEGER
C                = 010       NO DET, INVERSE OF LOWER TRIANGULAR.
C                = 011       NO DET, INVERSE OF UPPER TRIANGULAR.
C                = 100       DET, NO INVERSE.
C                = 110       DET, INVERSE OF LOWER TRIANGULAR.
C                = 111       DET, INVERSE OF UPPER TRIANGULAR.
C
C     ON RETURN
C
C        T       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     REAL(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. ABS(DET(1)) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C        INFO    INTEGER
C                INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR
C                AND THE INVERSE IS REQUESTED.
C                OTHERWISE INFO CONTAINS THE INDEX OF
C                A ZERO DIAGONAL ELEMENT OF T.
C
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSCAL
C     Fortran ABS,MOD
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 180
C
C        COMPUTE DETERMINANT
C
         IF (JOB/100 .EQ. 0) GO TO 70
            DET(1) = 1.0E0
            DET(2) = 0.0E0
            TEN = 10.0E0
            DO 50 I = 1, N
               DET(1) = T(I,I)*DET(1)
C           ...EXIT
               IF (DET(1) .EQ. 0.0E0) GO TO 60
   10          IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20
                  DET(1) = TEN*DET(1)
                  DET(2) = DET(2) - 1.0E0
               GO TO 10
   20          CONTINUE
   30          IF (ABS(DET(1)) .LT. TEN) GO TO 40
                  DET(1) = DET(1)/TEN
                  DET(2) = DET(2) + 1.0E0
               GO TO 30
   40          CONTINUE
   50       CONTINUE
   60       CONTINUE
   70    CONTINUE
C
C        COMPUTE INVERSE OF UPPER TRIANGULAR
C
         IF (MOD(JOB/10,10) .EQ. 0) GO TO 170
            IF (MOD(JOB,10) .EQ. 0) GO TO 120
C              BEGIN BLOCK PERMITTING ...EXITS TO 110
                  DO 100 K = 1, N
                     INFO = K
C              ......EXIT
                     IF (T(K,K) .EQ. 0.0E0) GO TO 110
                     T(K,K) = 1.0E0/T(K,K)
                     TEMP = -T(K,K)
                     CALL SSCAL(K-1,TEMP,T(1,K),1)
                     KP1 = K + 1
                     IF (N .LT. KP1) GO TO 90
                     DO 80 J = KP1, N
                        TEMP = T(K,J)
                        T(K,J) = 0.0E0
                        CALL SAXPY(K,TEMP,T(1,K),1,T(1,J),1)
   80                CONTINUE
   90                CONTINUE
  100             CONTINUE
                  INFO = 0
  110          CONTINUE
            GO TO 160
  120       CONTINUE
C
C              COMPUTE INVERSE OF LOWER TRIANGULAR
C
               DO 150 KB = 1, N
                  K = N + 1 - KB
                  INFO = K
C     ............EXIT
                  IF (T(K,K) .EQ. 0.0E0) GO TO 180
                  T(K,K) = 1.0E0/T(K,K)
                  TEMP = -T(K,K)
                  IF (K .NE. N) CALL SSCAL(N-K,TEMP,T(K+1,K),1)
                  KM1 = K - 1
                  IF (KM1 .LT. 1) GO TO 140
                  DO 130 J = 1, KM1
                     TEMP = T(K,J)
                     T(K,J) = 0.0E0
                     CALL SAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1)
  130             CONTINUE
  140             CONTINUE
  150          CONTINUE
               INFO = 0
  160       CONTINUE
  170    CONTINUE
  180 CONTINUE
      RETURN
      END
*SUMBS
      SUBROUTINE SUMBS(X, N, LO, MID, HI)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO FIND A ZERO OR VALUE CLOSEST TO ZERO IN
C     A SORTED VECTOR.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   HI,LO,MID,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N)
C
C  LOCAL SCALARS
      INTEGER
     +   CURHI,CURLO
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CURHI
C        THE UPPER BOUND OF THE CURRENT INTERVAL.
C     INTEGER CURLO
C        THE LOWER BOUND OF THE CURRENT INTERVAL.
C     INTEGER HI
C        INPUT PARAMETER.  THE UPPER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER LO
C        INPUT PARAMETER.  THE LOWER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER MID
C        OUTPUT PARAMETER.  THE MIDPOINT OF THE CURRENT
C        INTERVAL, AND ON EXIT THE POINT IN THE INITIAL
C        INTERVAL CLOSEST TO ZERO.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ARRAY X.
C     REAL X(N)
C        INPUT PARAMETER.  THE ARRAY X IN WHICH THE SEARCH FOR
C        A (NEAR) ZERO VALUE IS MADE.
C
C     BINARY SEARCH OF X FOR 0.0E0 OR CLOSEST TO IT.
C
      CURLO = LO
      CURHI = HI
C
C     SEE IF ZERO IS OUT OF THE RANGE X(LO) TO X(HI).
C
      IF (X(CURLO).LT.0.0E0) GO TO 10
      MID = CURLO
      GO TO 50
   10 IF (X(CURHI).GT.0.0E0) GO TO 20
      MID = CURHI
      GO TO 50
C
C     LOCATE EITHER A ZERO OR A PAIR OF ADJACENT VALUES BETWEEN
C     WHICH THERE LIES A ZERO.
C
   20 IF (CURLO+1.EQ.CURHI) GO TO 30
      MID = (CURLO+CURHI)/2
      IF (0.0E0.LT.X(MID)) CURHI = MID
      IF (0.0E0.GT.X(MID)) CURLO = MID
      IF (0.0E0.EQ.X(MID)) GO TO 50
      GO TO 20
C
C     PICK AS MIDPOINT THE CURRENT ENDPOINT CLOSEST TO ZERO.
C
   30 IF (X(CURHI)+X(CURLO).GT.0.0E0) GO TO 40
      MID = CURHI
      GO TO 50
   40 MID = CURLO
   50 RETURN
      END
*SUMDS
      SUBROUTINE SUMDS(X, N, LO, MID, HI, XMEANW, SUMDA, SUMD2, SUMD3,
     +   SUMD4)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE UNWEIGHTED SUMS OF POWERS OF
C     DIFFERENCES FROM THE WEIGHTED MEAN FOR A SORTED
C     VECTOR IN WHICH THE MIDTH ELEMENT IS THE ELEMENT
C     CLOSEST TO ZERO.  USED BY THE STAT FAMILY.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUMD2,SUMD3,SUMD4,SUMDA,XMEANW
      INTEGER
     +   HI,LO,MID,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N)
C
C  LOCAL SCALARS
      REAL
     +   DIFF
      INTEGER
     +   CURHI,CURLO,I,IREV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CURHI
C        THE UPPER BOUND OF THE CURRENT INTERVAL.
C     INTEGER CURLO
C        THE LOWER BOUND OF THE CURRENT INTERVAL.
C     REAL DIFF
C        THE DIFFERENCES BETWEEN X(I) AND XMEANW.
C     INTEGER HI
C        INPUT PARAMETER.  THE UPPER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER I
C        A LOOP PARAMETER.
C     INTEGER IREV
C        A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT
C        IN THE REVERSE ORDER.
C     INTEGER LO
C        INPUT PARAMETER.  THE LOWER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER MID
C        INPUT PARAMETER.  THE INDEX OF THE ELEMENT IN X CLOSEST TO
C        ZERO IN VALUE.  THE POINT OUT FROM WHICH THE SUMMING IS
C        DONE.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ARRAY X.
C     REAL SUMDA
C        OUTPUT PARAMETER.  THE SUM OF THE ABSOLUTE VALUES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD2
C        OUTPUT PARAMETER.  THE SUM OF THE SQUARES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD3
C        OUTPUT PARAMETER.  THE SUM OF THE CUBES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD4
C        OUTPUT PARAMETER.  THE SUM OF THE HYPERCUBES OF THE
C        DIFFERENCES DIFF.
C     REAL X(N)
C        INPUT PARAMETER.  THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN.
C     REAL XMEANW
C        INPUT PARAMETER.  THE WEIGHTED MEAN OF X.
C
C     INITIALIZE SUMMATION VARIABLES.
C
      DIFF = X(MID) - XMEANW
      SUMDA = ABS(DIFF)
      SUMD2 = DIFF*DIFF
      SUMD3 = DIFF*DIFF*DIFF
      SUMD4 = DIFF*DIFF*DIFF*DIFF
      CURLO = MID - 1
      CURHI = MID + 1
C
C     SUM OUTWARDS FROM THE VALUE NEAREST ZERO.  THAT IS, SUM FROM
C     THE LEAST IN MAGNITUDE TO THE GREATEST.
C
   10 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 30
      IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 20
      DIFF = X(CURLO) - XMEANW
      SUMDA = SUMDA + ABS(DIFF)
      SUMD2 = SUMD2 + DIFF*DIFF
      SUMD3 = SUMD3 + DIFF*DIFF*DIFF
      SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
      CURLO = CURLO - 1
      GO TO 10
   20 DIFF = X(CURHI) - XMEANW
      SUMDA = SUMDA + ABS(DIFF)
      SUMD2 = SUMD2 + DIFF*DIFF
      SUMD3 = SUMD3 + DIFF*DIFF*DIFF
      SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
      CURHI = CURHI + 1
      GO TO 10
C
C     SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF
C     CENTER ZERO POINT.
C
   30 IF (CURHI.GT.HI) GO TO 50
      DO 40 I=CURHI,HI
         DIFF = X(I) - XMEANW
         SUMDA = SUMDA + ABS(DIFF)
         SUMD2 = SUMD2 + DIFF*DIFF
         SUMD3 = SUMD3 + DIFF*DIFF*DIFF
         SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
   40 CONTINUE
   50 IF (CURLO.LT.LO) GO TO 70
      DO 60 IREV=LO,CURLO
         I = LO - IREV + CURLO
         DIFF = X(I) - XMEANW
         SUMDA = SUMDA + ABS(DIFF)
         SUMD2 = SUMD2 + DIFF*DIFF
         SUMD3 = SUMD3 + DIFF*DIFF*DIFF
         SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
   60 CONTINUE
   70 RETURN
      END
*SUMID
      SUBROUTINE SUMID(X, N, XMEAN, SUMDI)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE THE SUM OF THE PRODUCTS OF I AND THE I TH
C     DIFFERENCE AMONG THE ELEMENTS OF THE VECTOR X - XMEAN.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUMDI,XMEAN
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N)
C
C  LOCAL SCALARS
      REAL
     +   DIFF
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DIFF
C        THE DIFFERENCE OF A VALUE OF X AND THE WEIGHTED MEAN OF X.
C     INTEGER I
C        A LOOP INDEX.
C     INTEGER N
C        INPUT PARAMETER.  THE NUMBER OF ELEMENTS IN X.
C     REAL SUMDI
C        OUTPUT PARAMETER.  THE SUM OF THE PRODUCTS OF I AND THE
C        ELEMENTS OF THE VECTOR X - XMEAN.
C     REAL X(N)
C        INPUT PARAMETER.  THE VECTOR OF N DATA VALUES.
C     REAL XMEAN
C        INPUT PARAMETER.  THE MEAN OF X.
C
      SUMDI = 0.0E0
      DO 10 I=1,N
         DIFF = X(I) - XMEAN
         SUMDI = SUMDI + I*DIFF
   10 CONTINUE
      RETURN
      END
*SUMIDW
      SUBROUTINE SUMIDW(X, W, N, XMEANW, SUMDI)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE THE SUM OF THE PRODUCTS OF I AND THE I TH
C     DIFFERENCE AMONG THE ELEMENTS OF THE VECTOR X - XMEANW WHICH
C     ARE NOT WEIGHTED ZERO.  (ELEMENTS WEIGHTED ZERO DO NOT
C     PRODUCE AN INCREMENT IN I.)
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUMDI,XMEANW
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   W(N),X(N)
C
C  LOCAL SCALARS
      REAL
     +   DIFF,I
      INTEGER
     +   K
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DIFF
C        THE DIFFERENCE OF A VALUE OF X AND THE WEIGHTED MEAN OF X.
C     REAL I
C        I COUNTS FROM 1 TO THE NUMBER OF NON-ZERO WEIGHTED ELEMENTS
C        FOUND IN X.
C     INTEGER K
C        A LOOP INDEX.
C     INTEGER N
C        INPUT PARAMETER.  THE NUMBER OF ELEMENTS IN X.
C     REAL SUMDI
C        OUTPUT PARAMETER.  THE SUM OF THE PRODUCTS OF I AND THE
C        NON-ZERO WEIGHTED ELEMENTS OF THE VECTOR X - XMEANW.
C     REAL W(N)
C        INPUT PARAMETER.  THE WEIGHTS VECTOR FOR X.
C     REAL X(N)
C        INPUT PARAMETER.  THE VECTOR OF N DATA VALUES.
C     REAL XMEANW
C        INPUT PARAMETER.  THE WEIGHTED MEAN OF X.
C
      I = 0.0E0
      SUMDI = 0.0E0
      DO 10 K=1,N
         IF (W(K).EQ.0.0E0) GO TO 10
         DIFF = X(K) - XMEANW
         I = I + 1.0E0
         SUMDI = SUMDI + I*DIFF
   10 CONTINUE
      RETURN
      END
*SUMOT
      SUBROUTINE SUMOT(STS, N, NNZW, WTS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE REPORTS THE RESULTS OF A STAT FAMILY
C     COMPUTATION OF 53 SELECTED STATISTICS.  THERE MAY OR
C     MAY NOT BE WEIGHTS.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NNZW
      LOGICAL
     +   WTS
C
C  ARRAY ARGUMENTS
      REAL
     +   STS(53)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPRT
C
C  LOCAL ARRAYS
      INTEGER
     +   ITEMP(10)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VERSP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        LOOP INDEX.
C     INTEGER IPRT
C        THE OUTPUT UNIT.
C     INTEGER ITEMP(10)
C        A TEMPORARY VECTOR OF INTEGER STORAGE.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ORIGINAL DATA VECTOR.
C     INTEGER NNZW
C        INPUT PARAMETER.  THE NUMBER OF VALUES IN THE ORIGINAL DATA
C        VECTOR WITH WEIGHTS GREATER THAN 0.0E0.
C     REAL STS(53)
C        INPUT PARAMETER.  THE VECTOR OF 53 STATISTICS COMPUTED.
C        ROW STATISTIC                    ROW STATISTIC
C         1  LENGTH OF VECTOR             TESTS FOR NONRANDOMNESS
C         2  NUMBER OF NONZERO WEIGHTS    23  NUMBER OF RUNS UP AND DOWN
C        MEASURES OF LOCATION             24  EXPECTED NUMBER OF RUNS
C         3  UNWEIGHTED MEAN              25  S.D. OF NUMBER OF RUNS
C         4  WEIGHTED MEAN                26  MEAN SQR. SUCCESSIVE DIFF.
C         5  MEDIAN                       27  MEAN SQR. SUCC. DIFF./VAR.
C         6  MID-RANGE                    DEVIATIONS FROM WTD MEAN
C         7  25 P.C. UNWTD. TRIMMED MEAN  28  NUMBER OF + SIGNS
C         8  25 P.C. WTD. TRIMMED MEAN    29  NUMBER OF - SIGNS
C        MEASURES OF DISPERSION           30  NUMBER OF RUNS
C         9  STANDARD DEVIATION (S.D.)    31  EXPECTED NUMBER OF RUNS
C        10  S.D. OF MEAN                 32  S.D. OF RUNS
C        11  RANGE                        33  DIFF./S.D. OF RUNS
C        12  MEAN VARIATION               OTHER STATISTICS
C        13  VARIANCE (VAR.)              34  MINIMUM
C        14  COEFFICIENT OF VARIATION     35  MAXIMUM
C        CONFIDENCE INTERVALS             36  BETA 1
C        15  LOWER CONFIDENCE LIMIT, MEAN 37  BETA 2
C        16  UPPER CONFIDENCE LIMIT, MEAN 38  WTD. SUM OF VALUES
C        17  LOWER CONFIDENCE LIMIT, S.D. 39  WTD. SUM OF SQUARES
C        18  UPPER CONFIDENCE LIMIT, S.D. 40  WTD. SUM OF SQRD. DEVS.
C        LINEAR TREND STATISTICS          41  STUDENTS T
C        19  SLOPE                        42  WTD. SUM OF ABS. VALUES
C        20  S.D. OF SLOPE                43  WTD. AVG. ABS. VALUES
C        21  SLOPE/S.D. OF SLOPE = T      44-53 FREQ. DISTRIBUTION
C        22  PROB ( X .GT. ABS(OBS. T))
C     LOGICAL WTS
C        INPUT PARAMETER.  A FLAG TO INDICATE WHETHER OR NOT THERE ARE
C        WEIGHTS.
C
C     BEGIN PRINTOUT
C
      CALL IPRINT(IPRT)
C
C     PRINT HEADING
C
      CALL VERSP(.TRUE.)
C
C     PRINT NUMBERS OF OBSERVATIONS, RAW AND NONZERO WEIGHTED.
C
      IF (.NOT.WTS) WRITE (IPRT,1000)
      IF (WTS) WRITE (IPRT,1010)
      IF (NNZW.NE.N) GO TO 10
      WRITE (IPRT,1020) NNZW
      GO TO 20
   10 WRITE (IPRT,1030) NNZW, N
      WRITE (IPRT,1040)
C
C     PRINT FREQUENCY DISTRIBUTIONS
C
   20 DO 30 I=1,10
         ITEMP(I) = STS(I+43)
   30 CONTINUE
      WRITE (IPRT,1050) (ITEMP(I),I=1,10)
C
C     PRINT MEASURES OF LOCATION AND DISPERSION
C
      WRITE (IPRT,1060)
      IF (STS(4).NE.0.0E0)
     +   WRITE (IPRT,1070) (STS(I+2),STS(I+8),I=1,6)
      IF (STS(4).EQ.0.0E0)
     +   WRITE (IPRT,1080) (STS(I+2),STS(I+8),I=1,5), STS(8)
C
C     PRINT CONFIDENCE INTERVALS
C
      WRITE (IPRT,1090) (STS(I),I=15,18)
C
C     PRINT LINEAR TREND AND OTHER STATISTICS, AND PRINT HEADING FOR
C     TESTS FOR NONRANDOMNESS
C
      WRITE (IPRT,1100)
     +   (STS(I),STS(I+15),I=19,22), (STS(I),I=38,41)
      ITEMP(1) = STS(23)
      ITEMP(2) = STS(28)
      ITEMP(3) = STS(29)
      ITEMP(4) = STS(30)
C
C     PRINT TESTS FOR NONRANDOMNESS
C
      WRITE (IPRT,1110) ITEMP(1), STS(42), STS(24), STS(43),
     +   (STS(I),I=25,27), (ITEMP(I),I=2,4), (STS(I),I=31,33)
C
C     PRINT FOOTNOTE
C
      WRITE (IPRT,1120)
      RETURN
C
 1000 FORMAT('+STATISTICAL ANALYSIS')
 1010 FORMAT('+WEIGHTED STATISTICAL ANALYSIS')
 1020 FORMAT(//5X, 4HN = , I5)
 1030 FORMAT(//5X, 4HN = , I5, 32H (NO. OF NON-ZERO WTS)    LENGTH,
     +   2H =, I5)
 1040 FORMAT(/5X, 45HALL COMPUTATIONS ARE BASED ON OBSERVATIONS WI,
     +   19HTH NON-ZERO WEIGHTS)
 1050 FORMAT(//5X, 28HFREQUENCY DISTRIBUTION (1-6), 7X, 10I6)
 1060 FORMAT(//5X, 26HMEASURES OF LOCATION (2-2), 34X, 10HMEASURES O,
     +   18HF DISPERSION (2-6))
 1070 FORMAT(/10X, 26HUNWEIGHTED MEAN          =, 1PE15.7, 20X,
     +   26HWTD STANDARD DEVIATION   =, E15.7/10X, 17HWEIGHTED MEAN    ,
     +   9H        =, E15.7, 20X, 26HWEIGHTED S.D. OF MEAN    =,
     +   E15.7/10X, 26HMEDIAN                   =, E15.7, 20X, 6HRANGE ,
     +   20H                   =, E15.7/10X, 23HMID-RANGE              ,
     +   3H  =, E15.7, 20X, 26HMEAN DEVIATION           =, E15.7/10X,
     +   26H25 PCT UNWTD TRIMMED MEAN=, E15.7, 20X, 16HVARIANCE        ,
     +   10H         =, E15.7/10X, 26H25 PCT WTD TRIMMED MEAN  =,
     +   E15.7, 20X, 26HCOEF. OF. VAR. (PERCENT) =, E15.7)
 1080 FORMAT(/10X, 26HUNWEIGHTED MEAN          =, 1PE15.7, 20X,
     +   26HWTD STANDARD DEVIATION   =, E15.7/10X, 17HWEIGHTED MEAN    ,
     +   9H        =, E15.7, 20X, 26HWEIGHTED S.D. OF MEAN    =,
     +   E15.7/10X, 26HMEDIAN                   =, E15.7, 20X, 6HRANGE ,
     +   20H                   =, E15.7/10X, 23HMID-RANGE              ,
     +   3H  =, E15.7, 20X, 26HMEAN DEVIATION           =, E15.7/10X,
     +   26H25 PCT UNWTD TRIMMED MEAN=, E15.7, 20X, 16HVARIANCE        ,
     +   10H         =, E15.7/10X, 26H25 PCT WTD TRIMMED MEAN  =,
     +   E15.7, 20X, 26HCOEFFICIENT OF VARIATION =, 13H    UNDEFINED/
     +   98X, 14H(MEAN IS ZERO))
 1090 FORMAT(///20X, 46HA TWO-SIDED 95 PCT CONFIDENCE INTERVAL FOR MEA,
     +   4HN IS, 1PE14.7, 4H TO , E14.7, 6H (2-2)/20X, 13HA TWO-SIDED 9,
     +   37H5 PCT CONFIDENCE INTERVAL FOR S.D. IS, E14.7, 4H TO ,
     +   E14.7, 6H (2-7))
 1100 FORMAT(///5X, 30HLINEAR TREND STATISTICS (5-1) , 30X, 6HOTHER ,
     +   10HSTATISTICS//10X, 5HSLOPE, 20X, 1H=, 1PE15.7, 20X, 7HMINIMUM,
     +   18X, 1H=, E15.7/10X, 13HS.D. OF SLOPE, 12X, 1H=, E15.7, 20X,
     +   7HMAXIMUM, 18X, 1H=, E15.7/10X, 26HSLOPE/S.D. OF SLOPE = T  =,
     +   E15.7, 20X, 8HBETA ONE, 17X, 1H=, E15.7/10X, 14HPROB EXCEEDING,
     +   21H ABS VALUE OF OBS T =, 0PF6.3, 20X, 8HBETA TWO, 17X, 1H=,
     + 1PE15.7/71X, 17HWTD SUM OF VALUES, 8X, 1H=, E15.7/71X, 7HWTD SUM,
     +   11H OF SQUARES, 7X, 1H=, E15.7/5X, 24HTESTS FOR NON-RANDOMNESS,
     +   42X, 22HWTD SUM OF DEV SQUARED, 4H   =, E15.7/71X, 9HSTUDENTS ,
     +   'T', 15X, 1H=, E15.7)
 1110 FORMAT(10X, 26HNO. OF RUNS UP AND DOWN  =, I5, 30X, 9HWTD SUM A,
     +   17HBSOLUTE VALUES  =, 1PE15.7/
     +   10X, 26HEXPECTED NO. OF RUNS     =,
     +   0PF7.1, 28X, 26HWTD AVE ABSOLUTE VALUES  =, 1PE15.7/
     +   10X, 26HS.D. OF NO. OF RUNS      =, 0PF8.2/
     +   10X, 26HMEAN SQ SUCCESSIVE DIFF  =, 1X, 1PE16.7/
     +   10X, 26HMEAN SQ SUCC DIFF/VAR    =, 0PF9.3///
     +   10X, 24HDEVIATIONS FROM WTD MEAN//
     +   15X, 21HNO. OF + SIGNS      =, I5/
     +   15X, 21HNO. OF - SIGNS      =, I5/
     +   15X, 21HNO. OF RUNS         =, I5/
     +   15X, 21HEXPECTED NO. OF RUNS=, F7.1/
     +   15X, 12HS.D. OF RUNS, 8X, 1H=, F8.2/
     +   15X, 21HDIFF./S.D. OF RUNS  =, F9.3)
 1120 FORMAT(///49H NOTE - ITEMS IN PARENTHESES REFER TO PAGE NUMBER,
     +   36H IN NBS HANDBOOK 91 (NATRELLA, 1966))
      END
*SUMSS
      SUBROUTINE SUMSS(X, N, LO, MID, HI, SUM1, SUM2, SUMA, XMEAN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE SUMS OF POWERS AND THE MEAN
C     FOR A SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS
C     THE ELEMENT CLOSEST TO ZERO.  USED BY THE STAT
C     FAMILY.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUM1,SUM2,SUMA,XMEAN
      INTEGER
     +   HI,LO,MID,N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N)
C
C  LOCAL SCALARS
      INTEGER
     +   CURHI,CURLO,I,IREV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CURHI
C        THE UPPER BOUND OF THE CURRENT INTERVAL.
C     INTEGER CURLO
C        THE LOWER BOUND OF THE CURRENT INTERVAL.
C     INTEGER HI
C        INPUT PARAMETER.  THE UPPER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER I
C        LOOP PARAMETER.
C     INTEGER IREV
C        A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT
C        IN THE REVERSE ORDER.
C     INTEGER LO
C        INPUT PARAMETER.  THE LOWER BOUND OF THE INITIAL INTERVAL.
C     INTEGER MID
C        INPUT PARAMETER.  THE INDEX OF THE ELEMENT IN X CLOSEST TO
C        ZERO IN VALUE.  THE POINT OUT FROM WHICH THE SUMMING IS
C        DONE.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ARRAY X.
C     REAL SUMA
C        OUTPUT PARAMETER.  THE SUM OF THE ABSOLUTE VALUES OF THE
C        ELEMENTS OF X.
C     REAL SUM1
C        OUTPUT PARAMETER.  THE SUM OF THE ELEMENTS OF X.
C     REAL SUM2
C        OUTPUT PARAMETER.  THE SUM OF THE SQUARES OF THE
C        ELEMENTS OF X.
C     REAL X(N)
C        INPUT PARAMETER.  THE DATA ARRAY X OVER WHICH THE SUMS ARE
C        TAKEN.
C     REAL XMEAN
C        OUTPUT PARAMETER.  THE UNWEIGHTED MEAN OF X.
C
C     INITIALIZE SUMMATION VARIABLES.
C
      SUM1 = X(MID)
      SUM2 = X(MID)*X(MID)
      SUMA = ABS(X(MID))
      CURLO = MID - 1
      CURHI = MID + 1
C
C     SUM OUTWARDS FROM THE VALUE NEAREST ZERO.  THAT IS, SUM FROM
C     THE LEAST IN MAGNITUDE TO THE GREATEST.
C
   10 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 30
      IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 20
      SUM1 = SUM1 + X(CURLO)
      SUM2 = SUM2 + X(CURLO)*X(CURLO)
      SUMA = SUMA + ABS(X(CURLO))
      CURLO = CURLO - 1
      GO TO 10
   20 SUM1 = SUM1 + X(CURHI)
      SUM2 = SUM2 + X(CURHI)*X(CURHI)
      SUMA = SUMA + ABS(X(CURHI))
      CURHI = CURHI + 1
      GO TO 10
C
C     SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF
C     CENTER ZERO POINT.
C
   30 IF (CURHI.GT.HI) GO TO 50
      DO 40 I=CURHI,HI
         SUM1 = SUM1 + X(I)
         SUM2 = SUM2 + X(I)*X(I)
         SUMA = SUMA + ABS(X(I))
   40 CONTINUE
   50 IF (CURLO.LT.LO) GO TO 70
      DO 60 IREV=LO,CURLO
         I = LO - IREV + CURLO
         SUM1 = SUM1 + X(I)
         SUM2 = SUM2 + X(I)*X(I)
         SUMA = SUMA + ABS(X(I))
   60 CONTINUE
   70 XMEAN = SUM1/(HI-LO+1)
      RETURN
      END
*SUMTS
      SUBROUTINE SUMTS(X, N, ALPHA, SUMT1, XTRM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE THE UNWEIGHTED TRIMMED MEAN FOR
C     A SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS THE ELEMENT
C     CLOSEST TO ZERO.  USED BY THE STAT FAMILY.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   ALPHA,SUMT1,XTRM
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   X(N)
C
C  LOCAL SCALARS
      INTEGER
     +   CURHI,CURLO,I,IREV,ITHI,ITLO,MID,NALPHA
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SUMBS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        INPUT PARAMETER.  THE PERCENTAGE OF POINTS TO TRIM
C        FROM EACH END OF THE ARRAY X FOR THE TRIMMED MEAN.
C     INTEGER CURHI
C        THE UPPER BOUND OF THE CURRENT INTERVAL.
C     INTEGER CURLO
C        THE LOWER BOUND OF THE CURRENT INTERVAL.
C     INTEGER I
C        LOOP PARAMETER.
C     INTEGER IREV
C        A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT
C        IN THE REVERSE ORDER.
C     INTEGER ITHI
C        THE COMPUTED UPPER BOUND SUCH THAT ALPHA PER
C        CENT OF THE POSITIVELY WEIGHTED POINTS ARE
C        OMITTED.
C     INTEGER ITLO
C        THE COMPUTED LOWER BOUND SUCH THAT ALPHA PER
C        CENT OF THE POSITIVELY WEIGHTED POINTS ARE
C        OMITTED.
C     INTEGER MID
C        THE INDEX OF THE ELEMENT IN X CLOSEST TO ZERO IN VALUE.
C        THE POINT OUT FROM WHICH THE SUMMING IS DONE.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ARRAY X.
C     INTEGER NALPHA
C        THE INTEGER WHICH IS ALPHA PER CENT OF N.
C     REAL SUMT1
C        OUTPUT PARAMETER.  THE UNWEIGHTED SUM OF THE TRIMMED
C        ARRAY.  ZERO-WEIGHTED ELEMENTS ARE OMITTED.
C     REAL X(N)
C        INPUT PARAMETER.  THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN.
C     REAL XTRM
C        OUTPUT PARAMETER.  THE UNWEIGHTED, TRIMMED MEAN OF X.
C
C     SET UP LIMITS TRIMMING THE NUMBER OF VALUES AT EACH END
C     BY ALPHA PER CENT.
C
      NALPHA = ALPHA*N
      ITLO = NALPHA + 1
      ITHI = N - NALPHA
      CALL SUMBS(X, N, ITLO, MID, ITHI)
C
C     INITIALIZE SUMMATION VARIABLES.
C
      SUMT1 = X(MID)
      CURLO = MID - 1
      CURHI = MID + 1
C
C     SUM OUTWARDS FROM THE VALUE NEAREST ZERO.  THAT IS, SUM FROM
C     THE LEAST IN MAGNITUDE TO THE GREATEST.
C
   10 IF (CURHI.GT.ITHI .OR. CURLO.LT.ITLO) GO TO 30
      IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 20
      SUMT1 = SUMT1 + X(CURLO)
      CURLO = CURLO - 1
      GO TO 10
   20 SUMT1 = SUMT1 + X(CURHI)
      CURHI = CURHI + 1
      GO TO 10
C
C     SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF
C     CENTER ZERO POINT.
C
   30 IF (CURHI.GT.ITHI) GO TO 50
      CURHI = MAX(CURHI,ITLO)
      DO 40 I=CURHI,ITHI
         SUMT1 = SUMT1 + X(I)
   40 CONTINUE
   50 IF (CURLO.LT.ITLO) GO TO 70
      CURLO = MIN(CURLO,ITHI)
      DO 60 IREV=ITLO,CURLO
         I = ITLO - IREV + CURLO
         SUMT1 = SUMT1 + X(I)
   60 CONTINUE
   70 XTRM = SUMT1/(N-2*NALPHA)
      RETURN
      END
*SUMWDS
      SUBROUTINE SUMWDS(X, W, N, LO, MID, HI, XMEANW, SUMDA, SUMWD2,
     +   SUMD2, SUMD3, SUMD4)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE WEIGHTED AND UNWEIGHTED SUMS
C     OF POWERS OF DIFFERENCES FROM THE WEIGHTED MEAN FOR A
C     SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS THE ELEMENT
C     CLOSEST TO ZERO.  USED BY THE STAT FAMILY.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUMD2,SUMD3,SUMD4,SUMDA,SUMWD2,XMEANW
      INTEGER
     +   HI,LO,MID,N
C
C  ARRAY ARGUMENTS
      REAL
     +   W(N),X(N)
C
C  LOCAL SCALARS
      REAL
     +   DIFF
      INTEGER
     +   CURHI,CURLO,I,IREV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CURHI
C        THE UPPER BOUND OF THE CURRENT INTERVAL.
C     INTEGER CURLO
C        THE LOWER BOUND OF THE CURRENT INTERVAL.
C     REAL DIFF
C        THE DIFFERENCES BETWEEN X(I) AND XMEANW.
C     INTEGER HI
C        INPUT PARAMETER.  THE UPPER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER I
C        A LOOP PARAMETER.
C     INTEGER IREV
C        A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT
C        IN THE REVERSE ORDER.
C     INTEGER LO
C        INPUT PARAMETER.  THE LOWER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER MID
C        INPUT PARAMETER.  THE INDEX OF THE ELEMENT IN X CLOSEST TO
C        ZERO IN VALUE.  THE POINT OUT FROM WHICH THE SUMMING IS
C        DONE.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ARRAY X.
C     REAL SUMDA
C        OUTPUT PARAMETER.  THE SUM OF THE ABSOLUTE VALUES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD2
C        OUTPUT PARAMETER.  THE SUM OF THE SQUARES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD3
C        OUTPUT PARAMETER.  THE SUM OF THE CUBES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMD4
C        OUTPUT PARAMETER.  THE SUM OF THE HYPERCUBES OF THE
C        DIFFERENCES DIFF.
C     REAL SUMWD2
C        OUTPUT PARAMETER.  THE WEIGHTED SUM OF THE SQUARES OF
C        THE DIFFERENCES DIFF.
C     REAL W(N)
C        INPUT PARAMETER.  THE ARRAY OF WEIGHTS.
C     REAL X(N)
C        INPUT PARAMETER.  THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN.
C     REAL XMEANW
C        INPUT PARAMETER.  THE WEIGHTED MEAN OF X.
C
C     INITIALIZE SUMMATION VARIABLES.
C
      SUMDA = 0.0E0
      SUMWD2 = 0.0E0
      SUMD2 = 0.0E0
      SUMD3 = 0.0E0
      SUMD4 = 0.0E0
      IF (W(MID).EQ.0.0E0) GO TO 10
      DIFF = X(MID) - XMEANW
      SUMDA = ABS(DIFF)
      SUMWD2 = W(MID)*DIFF*DIFF
      SUMD2 = DIFF*DIFF
      SUMD3 = DIFF*DIFF*DIFF
      SUMD4 = DIFF*DIFF*DIFF*DIFF
   10 CURLO = MID - 1
      CURHI = MID + 1
C
C     SUM OUTWARDS, BOULDER, COLORADO FROM THE VALUE NEAREST ZERO.  THAT
C     THE LEAST IN MAGNITUDE TO THE GREATEST.
C
   20 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 60
      IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 40
      IF (W(CURLO).EQ.0.0E0) GO TO 30
      DIFF = X(CURLO) - XMEANW
      SUMDA = SUMDA + ABS(DIFF)
      SUMWD2 = SUMWD2 + W(CURLO)*DIFF*DIFF
      SUMD2 = SUMD2 + DIFF*DIFF
      SUMD3 = SUMD3 + DIFF*DIFF*DIFF
      SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
   30 CURLO = CURLO - 1
      GO TO 20
   40 IF (W(CURHI).EQ.0.0E0) GO TO 50
      DIFF = X(CURHI) - XMEANW
      SUMDA = SUMDA + ABS(DIFF)
      SUMWD2 = SUMWD2 + W(CURHI)*DIFF*DIFF
      SUMD2 = SUMD2 + DIFF*DIFF
      SUMD3 = SUMD3 + DIFF*DIFF*DIFF
      SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
   50 CURHI = CURHI + 1
      GO TO 20
C
C     SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF
C     CENTER ZERO POINT.
C
   60 IF (CURHI.GT.HI) GO TO 80
      DO 70 I=CURHI,HI
         IF (W(I).EQ.0.0E0) GO TO 70
         DIFF = X(I) - XMEANW
         SUMDA = SUMDA + ABS(DIFF)
         SUMWD2 = SUMWD2 + W(I)*DIFF*DIFF
         SUMD2 = SUMD2 + DIFF*DIFF
         SUMD3 = SUMD3 + DIFF*DIFF*DIFF
         SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
   70 CONTINUE
   80 IF (CURLO.LT.LO) GO TO 100
      DO 90 IREV=LO,CURLO
         I = LO - IREV + CURLO
         IF (W(I).EQ.0.0E0) GO TO 90
         DIFF = X(I) - XMEANW
         SUMDA = SUMDA + ABS(DIFF)
         SUMWD2 = SUMWD2 + W(I)*DIFF*DIFF
         SUMD2 = SUMD2 + DIFF*DIFF
         SUMD3 = SUMD3 + DIFF*DIFF*DIFF
         SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF
   90 CONTINUE
  100 RETURN
      END
*SUMWSS
      SUBROUTINE SUMWSS(X, W, N, LO, MID, HI, NNZW, SUM1, SUMW1, SUMW2,
     +   SUMWA, SUMW, XMEAN, XMEANW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE WEIGHTED AND UNWEIGHTED SUMS OF
C     POWERS AND THE MEAN FOR A SORTED VECTOR IN WHICH THE MID TH
C     ELEMENT IS THE ELEMENT CLOSEST TO ZERO.  USED BY THE STAT
C     FAMILY.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   SUM1,SUMW,SUMW1,SUMW2,SUMWA,XMEAN,XMEANW
      INTEGER
     +   HI,LO,MID,N,NNZW
C
C  ARRAY ARGUMENTS
      REAL
     +   W(N),X(N)
C
C  LOCAL SCALARS
      INTEGER
     +   CURHI,CURLO,I,IREV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CURHI
C        THE UPPER BOUND OF THE CURRENT INTERVAL.
C     INTEGER CURLO
C        THE LOWER BOUND OF THE CURRENT INTERVAL.
C     INTEGER HI
C        INPUT PARAMETER.  THE UPPER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER I
C        LOOP PARAMETER.
C     INTEGER IREV
C        A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT
C        IN THE REVERSE ORDER.
C     INTEGER LO
C        INPUT PARAMETER.  THE LOWER BOUND OF THE INITIAL
C        INTERVAL.
C     INTEGER MID
C        INPUT PARAMETER.  THE INDEX OF THE ELEMENT IN X CLOSEST TO
C        ZERO IN VALUE.  THE POINT OUT FROM WHICH THE SUMMING IS
C        DONE.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ARRAY X.
C     INTEGER NNZW
C        INPUT PARAMETER.  THE NUMBER OF POSITIVELY WEIGHTED VALUES
C        IN X.
C     REAL SUMW
C        OUTPUT PARAMETER.  THE SUM OF THE WEIGHTS WT(I).
C     REAL SUMWA
C        OUTPUT PARAMETER.  THE WEIGHTED SUM OF THE ABSOLUTE
C        VALUES OF THE ELEMENTS OF X.
C     REAL SUMW1
C        OUTPUT PARAMETER.  THE WEIGHTED SUM OF THE ELEMENTS OF
C        X.
C     REAL SUMW2
C        OUTPUT PARAMETER.  THE WEIGHTED SUM OF THE SQUARES OF
C        THE ELEMENTS OF X.
C     REAL SUM1
C        OUTPUT PARAMETER.  THE UNWEIGHTED SUM OF THE ELEMENTS OF X.
C     REAL W(N)
C        INPUT PARAMETER.  THE ARRAY OF WEIGHTS.
C     REAL X(N)
C        INPUT PARAMETER.  THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN.
C     REAL XMEAN
C        OUTPUT PARAMETER.  THE UNWEIGHTED MEAN OF X.
C     REAL XMEANW
C        OUTPUT PARAMETER.  THE WEIGHTED MEAN OF X.
C
C     INITIALIZE SUMMATION VARIABLES.
C
      SUM1 = 0.0E0
      SUMW1 = 0.0E0
      SUMW2 = 0.0E0
      SUMWA = 0.0E0
      SUMW = 0.0E0
      IF (W(MID).EQ.0.0E0) GO TO 10
      SUM1 = X(MID)
      SUMW1 = W(MID)*X(MID)
      SUMW2 = W(MID)*X(MID)*X(MID)
      SUMWA = W(MID)*ABS(X(MID))
      SUMW = W(MID)
   10 CURLO = MID - 1
      CURHI = MID + 1
C
C     SUM OUTWARDS, FROM THE VALUE NEAREST ZERO.  THAT IS, FROM
C     THE LEAST IN MAGNITUDE TO THE GREATEST.
C
   20 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 60
      IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 40
      IF (W(CURLO).EQ.0.0E0) GO TO 30
      SUM1 = SUM1 + X(CURLO)
      SUMW1 = SUMW1 + W(CURLO)*X(CURLO)
      SUMW2 = SUMW2 + W(CURLO)*X(CURLO)*X(CURLO)
      SUMWA = SUMWA + W(CURLO)*ABS(X(CURLO))
      SUMW = SUMW + W(CURLO)
   30 CURLO = CURLO - 1
      GO TO 20
   40 IF (W(CURHI).EQ.0.0E0) GO TO 50
      SUM1 = SUM1 + X(CURHI)
      SUMW1 = SUMW1 + W(CURHI)*X(CURHI)
      SUMW2 = SUMW2 + W(CURHI)*X(CURHI)*X(CURHI)
      SUMWA = SUMWA + W(CURHI)*ABS(X(CURHI))
      SUMW = SUMW + W(CURHI)
   50 CURHI = CURHI + 1
      GO TO 20
C
C     SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF
C     CENTER ZERO POINT.
C
   60 IF (CURHI.GT.HI) GO TO 80
      DO 70 I=CURHI,HI
         IF (W(I).EQ.0.0E0) GO TO 70
         SUM1 = SUM1 + X(I)
         SUMW1 = SUMW1 + W(I)*X(I)
         SUMW2 = SUMW2 + W(I)*X(I)*X(I)
         SUMWA = SUMWA + W(I)*ABS(X(I))
         SUMW = SUMW + W(I)
   70 CONTINUE
   80 IF (CURLO.LT.LO) GO TO 100
      DO 90 IREV=LO,CURLO
         I = LO - IREV + CURLO
         IF (W(I).EQ.0.0E0) GO TO 90
         SUM1 = SUM1 + X(I)
         SUMW1 = SUMW1 + W(I)*X(I)
         SUMW2 = SUMW2 + W(I)*X(I)*X(I)
         SUMWA = SUMWA + W(I)*ABS(X(I))
         SUMW = SUMW + W(I)
   90 CONTINUE
  100 XMEAN = SUM1/NNZW
      XMEANW = SUMW1/SUMW
      RETURN
      END
*SUMWTS
      SUBROUTINE SUMWTS(X, W, N, NNZW, ALPHA, SUMT1, SUMTW1, XTRM,
     +   XTRMW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     A ROUTINE TO CALCULATE THE WEIGHTED AND UNWEIGHTED MEANS
C     FOR A SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS THE
C     ELEMENT CLOSEST TO ZERO.  USED BY THE STAT FAMILY.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  MAY 17, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   ALPHA,SUMT1,SUMTW1,XTRM,XTRMW
      INTEGER
     +   N,NNZW
C
C  ARRAY ARGUMENTS
      REAL
     +   W(N),X(N)
C
C  LOCAL SCALARS
      REAL
     +   SUMW
      INTEGER
     +   CURHI,CURLO,I,IREV,ITHI,ITLO,MID,NALPHA,NUM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SUMBS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALPHA
C        INPUT PARAMETER.  THE PERCENTAGE OF POINTS TO TRIM
C        FROM EACH END OF THE ARRAY X FOR THE TRIMMED MEAN.
C     INTEGER CURHI
C        THE UPPER BOUND OF THE CURRENT INTERVAL.
C     INTEGER CURLO
C        THE LOWER BOUND OF THE CURRENT INTERVAL.
C     INTEGER I
C        LOOP PARAMETER.
C     INTEGER IREV
C        A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT
C        IN THE REVERSE ORDER.
C     INTEGER ITHI
C        THE COMPUTED UPPER BOUND SUCH THAT ALPHA PER
C        CENT OF THE POSITIVELY WEIGHTED POINTS ARE
C        OMITTED.
C     INTEGER ITLO
C        THE COMPUTED LOWER BOUND SUCH THAT ALPHA PER
C        CENT OF THE POSITIVELY WEIGHTED POINTS ARE
C        OMITTED.
C     INTEGER MID
C        THE INDEX OF THE ELEMENT IN X CLOSEST TO ZERO IN VALUE.
C        THE POINT OUT FROM WHICH THE SUMMING IS DONE.
C     INTEGER N
C        INPUT PARAMETER.  THE LENGTH OF THE ARRAY X.
C     INTEGER NALPHA
C          THE INTEGER WHICH IS ALPHA PER CENT OF N.
C     INTEGER NNZW
C        INPUT PARAMETER.  THE NUMBER OF POSITIVELY WEIGHTED
C        VALUES IN X.
C     INTEGER NUM
C        THE NUMBER OF POINTS OMITTED SO FAR.
C     REAL SUMTW1
C        OUTPUT PARAMETER.  THE WEIGHTED SUM OF THE TRIMMED ARRAY
C        X.
C     REAL SUMT1
C        OUTPUT PARAMETER.  THE UNWEIGHTED SUM OF THE TRIMMED
C        ARRAY.  ZERO-WEIGHTED ELEMENTS ARE OMITTED.
C     REAL SUMW
C        THE SUM OF THE WEIGHTS W(I).
C     REAL W(N)
C        INPUT PARAMETER.  THE ARRAY OF WEIGHTS.
C     REAL X(N)
C        INPUT PARAMETER.  THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN.
C     REAL XTRM
C        OUTPUT PARAMETER.  THE UNWEIGHTED, TRIMMED MEAN OF X.
C     REAL XTRMW
C        OUTPUT PARAMETER.  THE WEIGHTED, TRIMMED MEAN OF X.
C
C     SET UP LIMITS TRIMMING THE NUMBER OF NON-ZERO WEIGHTED
C     VALUES BY ALPHA PER CENT AT EACH END OF THE RANGE OF
C     VALUES.
C
      NALPHA = ALPHA*NNZW
      NUM = 0
      DO 10 I=1,N
         IF (W(I).EQ.0.0E0) GO TO 10
         NUM = NUM + 1
         IF (NUM.EQ.NALPHA+1) GO TO 20
   10 CONTINUE
   20 ITLO = I
      NUM = 0
      DO 30 I=1,N
         IREV = N - I + 1
         IF (W(IREV).EQ.0.0E0) GO TO 30
         NUM = NUM + 1
         IF (NUM.EQ.NALPHA+1) GO TO 40
   30 CONTINUE
   40 ITHI = IREV
      CALL SUMBS(X, N, ITLO, MID, ITHI)
C
C     INITIALIZE SUMMATION VARIABLES.
C
      SUMT1 = 0.0E0
      SUMTW1 = 0.0E0
      SUMW = 0.0E0
      IF (W(MID).EQ.0.0E0) GO TO 50
      SUMT1 = X(MID)
      SUMTW1 = W(MID)*X(MID)
      SUMW = W(MID)
   50 CURLO = MID - 1
      CURHI = MID + 1
C
C     SUM OUTWARDS, BOULDER, COLORADO FROM THE VALUE NEAREST ZERO.  THAT
C     THE LEAST IN MAGNITUDE TO THE GREATEST.
C
   60 IF (CURHI.GT.ITHI .OR. CURLO.LT.ITLO) GO TO 100
      IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 80
      IF (W(CURLO).EQ.0.0E0) GO TO 70
      SUMT1 = SUMT1 + X(CURLO)
      SUMTW1 = SUMTW1 + W(CURLO)*X(CURLO)
      SUMW = SUMW + W(CURLO)
   70 CURLO = CURLO - 1
      GO TO 60
   80 IF (W(CURHI).EQ.0.0E0) GO TO 90
      SUMT1 = SUMT1 + X(CURHI)
      SUMTW1 = SUMTW1 + W(CURHI)*X(CURHI)
      SUMW = SUMW + W(CURHI)
   90 CURHI = CURHI + 1
      GO TO 60
C
C     SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF
C     CENTER ZERO POINT.
C
  100 IF (CURHI.GT.ITHI) GO TO 120
      CURHI = MAX(CURHI,ITLO)
      DO 110 I=CURHI,ITHI
         IF (W(I).EQ.0.0E0) GO TO 110
         SUMT1 = SUMT1 + X(I)
         SUMTW1 = SUMTW1 + W(I)*X(I)
         SUMW = SUMW + W(I)
  110 CONTINUE
  120 IF (CURLO.LT.ITLO) GO TO 140
      CURLO = MIN(CURLO,ITHI)
      DO 130 IREV=ITLO,CURLO
         I = ITLO - IREV + CURLO
         IF (W(I).EQ.0.0E0) GO TO 130
         SUMT1 = SUMT1 + X(I)
         SUMTW1 = SUMTW1 + W(I)*X(I)
         SUMW = SUMW + W(I)
  130 CONTINUE
  140 XTRM = SUMT1/(NNZW-2*NALPHA)
      XTRMW = SUMTW1/SUMW
      RETURN
      END
*SVPC
      SUBROUTINE SVPC(YM, N, NS, ISYM, ILOG, ISIZE, IRLIN, IBAR,
     +   YLB, YUB, XLB, XINC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH USER CONTROL OF THE PLOT SYMBOLS USED (LONG CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IRLIN,ISIZE,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'V',       'P',       'C',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 1
      MISS = .FALSE.
      LISYM = N
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL SVPC (Y, N, NS, ISYM, ILOG,'/
     +  '      +           ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)')
      END
*SVP
      SUBROUTINE SVP(YM, N, NS, ISYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH USER CONTROL OF THE PLOT SYMBOLS USED (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'V',       'P',       ' ',       ' ',       ' '/
C
C     DEFINE CONSTANTS
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 1
      ISIZE = -1
      MISS = .FALSE.
      LISYM = N
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL SVP (Y, N, NS, ISYM)')
      END
*SVPL
      SUBROUTINE SVPL(YM, N, NS, ISYM, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH USER CONTROL OF THE PLOT SYMBOL USED (LOG PLOT OPTION).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'V',       'P',       'L',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 1
      ISIZE = -1
      MISS = .FALSE.
      LISYM = N
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL SVPL (Y, N, NS, ISYM, ILOG)')
      END
*SVPMC
      SUBROUTINE SVPMC(YM, YMMISS, N, NS, ISYM, ILOG, ISIZE,
     +   IRLIN, IBAR, YLB, YUB, XLB, XINC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA AND USER CONTROL OF THE PLOT SYMBOL USED
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  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IRLIN,ISIZE,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'V',       'P',       'M',       'C',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 1
      MISS = .TRUE.
      LISYM = N
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL SVPMC (Y, YMISS, N, NS, ISYM, ILOG,'/
     +  '      +            ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)')
      END
*SVPM
      SUBROUTINE SVPM(YM, YMMISS, N, NS, ISYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA AND USER CONTROL OF THE PLOT SYMBOL USED
C     (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'V',       'P',       'M',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 1
      ISIZE = -1
      MISS = .TRUE.
      LISYM = N
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL SVPM (Y, YMISS, N, NS, ISYM)')
      END
*SVPML
      SUBROUTINE SVPML(YM, YMMISS, N, NS, ISYM, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA AND USER CONTROL OF THE PLOT SYMBOL USED
C     (LOG PLOT OPTION).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
      INTEGER
     +   ISYM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(N)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  'S',       'V',       'P',       'M',       'L',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 1
      ISIZE = -1
      MISS = .TRUE.
      LISYM = N
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL SVPML (Y, YMISS, N, NS, ISYM, ILOG)')
      END
*TAPER
      SUBROUTINE TAPER (Y, N, TAPERP, YT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER ROUTINE FOR APPLYING A SPLIT-COSINE-BELL
C     TAPER TO THE (CENTERED) OBSERVED SERIES Y, RETURNING THE TAPERED
C     SERIES IN YT.  THIS ROUTINE IS ADAPTED FROM BLOOMFIELDS
C     ROUTINE TAPER.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   TAPERP
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*),YT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   PI,WEIGHT
      INTEGER
     +   I,IPRT,J,M
      LOGICAL
     +   ERR01,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CENTER,EISGE,GETPI,IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS,INT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A VARIABLE USED TO INDICARE WHETHER A HEADING IS NEEDED FOR
C        ERROR MESSAGES (TRUE) OR NOT (FALSE).
C     INTEGER I
C        AN INDEXING VARIABLE.
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 LOGICAL UNIT NUMBER USED FOR OUTPUT.
C     INTEGER J
C        AN INDEXING VARIABLE.
C     CHARACTER*1 LN(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED
C        FOR ERRORS.
C     INTEGER M
C        THE NUMBER OF POINTS AT EACH END OF THE SERIES TO BE
C        TAPERED.
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     REAL PI
C        THE VALUE OF PI.
C     REAL TAPERP
C        THE TOTAL PERCENTAGE OF THE DATA TO BE TAPERED.
C     REAL WEIGHT
C        THE ITH TAPER WEIGHT.
C     REAL Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     REAL YT(N)
C        THE VECTOR IN WHICH THE TAPERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'T',       'A',       'P',       'E',       'R',       ' '/
      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, 17, 1, HEAD, ERR01, LN)
      IF (.NOT. ERR01) GO TO 5
C
      IERR = 1
      CALL IPRINT (IPRT)
      WRITE (IPRT, 1000)
      RETURN
C
    5 CONTINUE
C
      CALL CENTER (Y, N, YT)
C
      IF ((TAPERP .LE. 0.0E0) .OR. (TAPERP .GT. 1.0E0)) RETURN
C
      CALL GETPI(PI)
C
      M = INT(TAPERP * N + 0.5E0) / 2
      IF (M .EQ. 0) RETURN
C
      DO 20 I = 1, M
         WEIGHT = 0.5E0 - 0.5E0 * COS(PI * (I-0.5E0) / M)
         YT(I) = WEIGHT * YT(I)
         J = N + 1 - I
         YT(J) = WEIGHT * YT(J)
   20 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   36H       CALL TAPER (Y, N, TAPERP, YT))
      END
      subroutine timestamp ( )

c*******************************************************************************
c
cc TIMESTAMP prints out the current YMDHMS date as a timestamp.
c
c  Discussion:
c
c    This Fortran77 version is made available for cases where the
c    Fortran90 version cannot be used.
c
c  Modified:
c
c    16 September 2005
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    None
c
      implicit none

      character ( len = 8 ) date
      character ( len = 10 ) time

      call date_and_time ( date, time )

      write ( *, '(a8,2x,a10)' ) date, time

      return
      end
*UASCFT
      SUBROUTINE UASCFT (ACOV, LAGMAX, LACOV, IAR, PHI, N, VAR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE AUTOREGRESSIVE MODEL COEFFICIENTS
C     FOR AN ORDER IAR MODEL USING DURBINS RECURSIVE METHOD.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   VAR
      INTEGER
     +   IAR,LACOV,LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(LACOV),PHI(IAR)
C
C  LOCAL SCALARS
      REAL
     +   RSS
      INTEGER
     +   L
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ARCOEF
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE ARRAY OF AUTOCOVARIANCE ESTIMATES.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER L
C        AN INDEX VARIABLE.
C     INTEGER LACOV
C        THE LENGTH OF THE ARRAY ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES.
C     REAL PHI(IAR)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL RSS, VAR
C
C
      PHI(1) = ACOV(2) / ACOV(1)
      RSS = ACOV(1) * N * (1.0E0 - PHI(1)*PHI(1))
C
      IF (IAR .LE. 1) GO TO 20
C
      DO 10 L = 2, IAR
         CALL ARCOEF(ACOV(2), PHI, RSS, L, LAGMAX, ACOV(1))
   10 CONTINUE
C
   20 VAR = RSS / (N-IAR-1)
C
      RETURN
C
      END
*UASDV
      SUBROUTINE UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX,
     +   FREQ, N, LAGMAX, FTEST, AIC, WORK, LACOV, LWORK, DELTA, ISORT,
     +   ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR,
     +   WINDOW, NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN DRIVER FOR COMPUTING THE AUTOREGRESSIVE
C     (AND FOURIER) SPECTRUMS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,VAR
      INTEGER
     +   IAR,LACOV,LAG,LAGMAX,LAIC,LPCV,LPHI,LSPC,LWORK,N,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(LACOV),AIC(LAIC),FREQ(NF),FTEST(2,LAGMAX),PHI(LPHI),
     +   SPCA(LSPC),SPCF(LSPC),WORK(LWORK),XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISORT(NF),ISYM(LPCV)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL WINDOW
C
C  LOCAL SCALARS
      REAL
     +   ALOW,AUP,BW,DF,SPCAMN,SPCAMX,SPCFMN,SPCFMX,XPLTMN,XPLTMX,
     +   YPLTMN,YPLTMX
      INTEGER
     +   ISPCER,NPTS,NSPCA,NSPCF,NW
      LOGICAL
     +   AICPRT
C
C  LOCAL ARRAYS
      INTEGER
     +   LAGS(1),NLPPA(1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AOS,SETFRQ,SPCCK,UASCFT,UASEST,UASORD,UASOUT,UFSLAG,UFSMN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC IABS,INT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS.
C     REAL AIC(LAIC)
C        THE ARRAY CONTAINING THE AKAIKES CRITERIA FOR EACH ORDER(?).
C     LOGICAL AICPRT
C        AN INDICATOR VARIABLE USED TO DETERMINE IF THE AKIAKE
C        INFORMATION CRITERIA AND CHI SQUARED STATISTICS SHOULD
C        BE PRINTED.
C     REAL ALOW
C        A FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL AUP
C        A FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS.
C     REAL BW
C        THE BANDWIDTH.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL DF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE
C        SPECTRUM ESTIMATES ARE TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     REAL FTEST(2,LAGMAX)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER ISORT(NF)
C        AN ARRAY USED FOR SORTING.
C     INTEGER LSPC
C         THE ACTUAL FIRST DIMENSION FOR THE SPECTRUM ARRAYS.
C     INTEGER ISPCER
C        AN ERROR FLAG USED FOR THE SPECTRUM PLOTS.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE COVARIANCE ARRAYS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(1)
C        THE LAG WINDOW TRUNCATION POINT RETURNED FROM UFSLAG.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER LWORK
C        THE ACTUAL LENGTH OF THE WORK ARRAY.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     INTEGER NLPPA(1)
C        A DUMMY ARRAY
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     INTEGER NSPCA, NSPCF
C        THE NUMBER OF VALID SPECTRUM ESTIMATES FOR THE AUTOREGRESSIVE
C        AND FOURIER SPECTRUMS, RESPECTIVELY.
C     INTEGER NW
C        THE NUMBER OF LAG WINDOW TRUNCATION POINTS SELCTED.
C     REAL PHI(LPHI)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL SPCA(LSPC)
C        THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCAMN, SPCAMX
C        THE MINIMUM AND MAXIMUM AUTOREGRESSIVE SPECTRUM VALUE TO BE
C        PLOTTED.
C     REAL SPCF(LSPC)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL SPCFMN, SPCFMX
C        THE MINIMUM AND MAXIMUM FOURIER SPECTRUM VALUE TO BE PLOTTED.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE.
C     EXTERNAL WINDOW
C        THE TYPE OF WINDOW TO BE USED.
C     REAL WORK(LWORK)
C        THE WORK ARRAY.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
      NW = 1
C
      IF (LAG.LE.0) THEN
C
C     SET THE LAG WINDOW TRUNCATION POINT TO BE USED FOR THE
C     FOURIER SPECTRUM ESTIMATES.
C
         CALL UFSLAG(ACOV, LAGMAX, LAGS, N, NW, NW, LACOV)
         LAG = LAGS(1)/2
      END IF
C
C     SET FREQUENCIES FOR THE SPECTRUM.
C
      CALL SETFRQ(FREQ, NF, 1, FMIN, FMAX, DELTA)
C
C     COMPUTE THE FOURIER SPECTRUM ESTIMATES
C
      CALL UFSMN(ACOV, NLPPA, LAG, DF, NF, FREQ, ALPHA, BW, SPCF,
     +  ALOW, AUP, LACOV, LSPC, WINDOW, WORK, LWORK, N, DELTA,
     +  .FALSE., 1)
C
      AICPRT = .FALSE.
C
      IF (IAR.LT.0) THEN
C
C     USER HAS CHOSEN ORDER.
C     COMPUTE COEFFICIENTS AND VARIANCE USING DURBINS RECURSIVE METHOD.
C
         CALL UASCFT(ACOV, LAGMAX, LACOV, IABS(IAR), PHI, N, VAR)
C
      ELSE IF (IAR.EQ.0) THEN
C
C     SELECT MODEL ORDER AND COMPUTE COEFFICIENTS AND VARIANCE.
C
         AICPRT = .TRUE.
         CALL AOS(N, LAGMAX, ACOV, WORK, IAR, VAR, PHI,
     +            WORK, AIC, FTEST, LACOV, LAIC)
      END IF
C
C     COMPUTE THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C
      CALL UASEST(IABS(IAR), VAR, PHI, NF, FREQ, DELTA, SPCA, LPHI,
     +   LSPC)
C
      IF (NPRT.EQ.0) RETURN
C
C     SET PLOTTING VECTORS.
C
      XPLTMN = FMIN
      XPLTMX = FMAX
C
      YPLTMN = 0.0E0
      YPLTMX = 0.0E0
C
      CALL SPCCK(SPCF, ISORT, NF, SPCFMN, SPCFMX, NSPCF, ISPCER)
      IF (ISPCER.NE.0) GO TO 40
      CALL SPCCK(SPCA, ISORT, NF, SPCAMN, SPCAMX, NSPCA, ISPCER)
      IF (ISPCER.NE.0) GO TO 40
C
      CALL UASORD(SPCF, SPCA, SPCFMN, SPCFMX, SPCAMN, SPCAMX, FREQ, NF,
     +   XAXIS, YAXIS, ISYM, NPTS, LSPC, LPCV, NSPCF, NSPCA, BW, ALOW,
     +   AUP, XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT)
C
C     PRINT RESULTS
C
   40 CALL UASOUT(XAXIS, YAXIS, ISYM, NPTS, BW, INT(DF+0.5E0), LAG,
     +   IABS(IAR), PHI, ISPCER, LPCV, XPLTMN, XPLTMX, YPLTMN, YPLTMX,
     +   FTEST, AIC, LAIC, VAR, NPRT, LAGMAX, AICPRT, N, NMSUB)
C
      RETURN
      END
*UASER
      SUBROUTINE UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV,
     +   NF, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR THE TIME SERIES
C     FOURIER UNIVARIATE SPECTRUM ANALYSIS 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  (JRD)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IAR,LACOV,LAG,LAGMAX,LDSMIN,LDSTAK,LYFFT,N,NF,NFFT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),PHI(*)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,NV
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERR(20)
      CHARACTER
     +   L1(8)*1,LACV(8)*1,LACV1M(8)*1,LACV1P(8)*1,LIAR(8)*1,
     +   LLACOV(8)*1,LLAG(8)*1,LLDS(8)*1,LLGMX(8)*1,LLGMX1(8)*1,
     +   LLGMXM(8)*1,LLGMXP(8)*1,LLYFFT(8)*1,LN(8)*1,LNF(8)*1,
     +   LNM1(8)*1,LPHI(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,ERVII
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,IABS
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE FUNCTION.
C     LOGICAL ERR(20)
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 IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     CHARACTER*1 LACV(8), LACV1M(8), LACV1P(8),
C    *   LIAR(8), LLACOV(8), LLAG(8), LLGMX(8), LLGMXM(8),
C    *   LLGMXP(8),  LLGMX1(8), LLDS(8), LN(8), LNF(8), LNM1(8),
C    *   LLYFFT(8), LPHI(8), L1(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE ARGUMENT(S)
C        CHECKED FOR ERRORS.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THE USER CALLED SUBROUTINE.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND WHEN CHECKING VECTOR LAGS.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     REAL PHI(IAR)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C
C
C     SET UP NAME ARRAYS
C
      DATA LACV(1), LACV(2), LACV(3), LACV(4), LACV(5), LACV(6),
     +   LACV(7), LACV(8) /'A','C','O','V',' ',' ',' ',' '/
      DATA LACV1M(1), LACV1M(2), LACV1M(3), LACV1M(4), LACV1M(5),
     +   LACV1M(6), LACV1M(7), LACV1M(8) /'-','A','C','O','V','(','1',
     +   ')'/
      DATA LACV1P(1), LACV1P(2), LACV1P(3), LACV1P(4), LACV1P(5),
     +   LACV1P(6), LACV1P(7), LACV1P(8) /'+','A','C','O','V','(','1',
     +   ')'/
      DATA LIAR(1), LIAR(2), LIAR(3), LIAR(4), LIAR(5),
     +   LIAR(6), LIAR(7), LIAR(8) /'I','A','R',' ',' ',' ',' ',
     +   ' '/
      DATA LLACOV(1), LLACOV(2), LLACOV(3), LLACOV(4), LLACOV(5),
     +   LLACOV(6), LLACOV(7), LLACOV(8) /'L','A','C','O','V',' ',' ',
     +   ' '/
      DATA LLAG(1), LLAG(2), LLAG(3), LLAG(4), LLAG(5), LLAG(6),
     +   LLAG(7), LLAG(8) /'L','A','G',' ',' ',' ',' ',' '/
      DATA LLGMX(1), LLGMX(2), LLGMX(3), LLGMX(4), LLGMX(5),
     +   LLGMX(6), LLGMX(7), LLGMX(8) /'L','A','G','M','A','X',' ',
     +   ' '/
      DATA LLGMXM(1), LLGMXM(2), LLGMXM(3), LLGMXM(4), LLGMXM(5),
     +   LLGMXM(6), LLGMXM(7), LLGMXM(8) /'-','L','A','G','M','A','X',
     +   ' '/
      DATA LLGMXP(1), LLGMXP(2), LLGMXP(3), LLGMXP(4), LLGMXP(5),
     +   LLGMXP(6), LLGMXP(7), LLGMXP(8) /'+','L','A','G','M','A','X',
     +   ' '/
      DATA LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5),
     +   LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+',
     +   '1'/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7),
     +   LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/
      DATA LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6),
     +   LNM1(7), LNM1(8) /'N','-','1',' ',' ',' ',' ',' '/
      DATA LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     +   LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ',
     +   ' '/
      DATA LPHI(1), LPHI(2), LPHI(3), LPHI(4), LPHI(5), LPHI(6),
     +   LPHI(7), LPHI(8) /'P','H','I',' ',' ',' ',' ',' '/
      DATA L1(1), L1(2), L1(3), L1(4), L1(5), L1(6), L1(7), L1(8) /'1',
     +   ' ',' ',' ',' ',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
C
      IERR = 0
      HEAD = .TRUE.
C
      DO 10 I=1,20
         ERR(I) = .FALSE.
   10 CONTINUE
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR(1), LN)
C
      IF ((.NOT.OPTION(3))) GO TO 15
C
      CALL ERVII(NMSUB, LACV, ACOV, LAGMAX+1, -ABS(ACOV(1)),
     +   ABS(ACOV(1)), 0, HEAD, 4, NV, ERR(15), LACV1M, LACV1P)
C
      CALL EISII(NMSUB, LLGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2),
     +   L1, LNM1)
C
      IF (OPTION(2)) THEN
         CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 8, HEAD, ERR(3),
     +   LLGMX1)
      ELSE
         CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 7, HEAD, ERR(3),
     +   LLGMX1)
      END IF
C
   15 IF (OPTION(1) .AND. (.NOT.ERR(1)))
     +   CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR(4),
     +   LLYFFT)
C
      IF (OPTION(1) .AND. (.NOT.OPTION(4)))
     +   CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(5), LLDS)
C
      IF (OPTION(4)) GO TO 30
C
      DO 20 I=1,15
         IF (ERR(I)) GO TO 50
   20 CONTINUE
C
      RETURN
C
   30 CONTINUE
C
      CALL EISII(NMSUB, LIAR, IAR, -IABS(LAGMAX), IABS(LAGMAX), 1, HEAD,
     +   ERR(6), LLGMXM, LLGMXP)
C
      CALL ERVII(NMSUB, LPHI, PHI, IAR, -1.0E0, 1.0E0, 0, HEAD, 1, NV,
     +   ERR(7), L1, L1)
C
      IF (.NOT.OPTION(3))
     +   CALL EISII(NMSUB, LLGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2),
     +   L1, LNM1)
C
      CALL EISII(NMSUB, LLAG, LAG, -IABS(LAGMAX), IABS(LAGMAX), 1, HEAD,
     +   ERR(8), LLGMXM, LLGMXP)
C
      CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR(9), LNF)
C
      IF (ERR(1) .OR. ERR(2) .OR. ERR(9)) GO TO 50
C
      CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(14), LLDS)
C
      DO 40 I=1,15
         IF (ERR(I)) GO TO 50
   40 CONTINUE
C
      RETURN
C
   50 CONTINUE
      IERR = 1
      RETURN
C
      END
*UASEST
      SUBROUTINE UASEST (IAR, VAR, PHI, NF, FREQ, DELTA, SPCA, LPHI,
     +   ISPC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CALCULATES THE AUTOREGRESSIVE SPECTRUM.  IT IS
C        MODELED AFTER SUBROUTINE UASEC BY DICK JONES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   DELTA,VAR
      INTEGER
     +   IAR,ISPC,LPHI,NF
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),PHI(LPHI),SPCA(ISPC)
C
C  LOCAL SCALARS
      REAL
     +   ARG,EI,ER,EXI,EXR,EXRTMP,PI,TI,TR
      INTEGER
     +   I,J
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS,SIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ARG
C        THE ARGUMENT FOR THE SINE AND COSINE FUNCTIONS USED IN
C        CALCULATIONS OF THE SPECTRUM.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL EI, ER, EXI, EXR, EXRTMP
C        'COMPLEX' VARIABLES USED IN THE COMPUTATIONS.
C     REAL FREQ(NF)
C        THE ARRAY CONTAINING THE FREQUENCIES AT WHICH THE SPECTRUM
C        IS TO BE COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER ISPC
C        THE LENGTH OF THE ARRAY SPCA.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER LPHI
C        THE LENGTH OF THE ARRAY PHI.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     REAL PHI(LPHI)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL PI
C        THE VALUE OF PI.
C     REAL SPCA(ISPC)
C        THE ARRAY IN WHICH THE AUTOREGRESSIVE SPECTRUM IS STORED.
C     REAL TI, TR
C        A VARIABLE USED IN THE COMPUTATIONS.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR).
C
      CALL GETPI(PI)
C
      DO 20 J=1,NF
         SPCA(J) = DELTA * VAR
         IF (IAR.GE.1) THEN
            IF (DELTA.EQ.1.0E0) THEN
               IF (FREQ(J).EQ.0.0E0) THEN
                  ER = 1.0E0
                  EI = 0.0E0
               ELSE IF (FREQ(J).EQ.0.25E0) THEN
                  ER = 0.0E0
                  EI = 1.0E0
               ELSE IF (FREQ(J).EQ.0.5E0) THEN
                  ER = -1.0E0
                  EI = 0.0E0
               ELSE
                  ARG = 2.0E0 * PI * DELTA * FREQ(J)
                  ER = COS(ARG)
                  EI = SIN(ARG)
               END IF
            ELSE
               ARG = 2.0E0 * PI * DELTA * FREQ(J)
               ER = COS(ARG)
               EI = SIN(ARG)
            END IF
            EXR = 1.0E0
            EXI = 0.0E0
            TR = 1.0E0
            TI = 0.0E0
            DO 10 I=1,IAR
               EXRTMP = EXR*ER - EXI*EI
               EXI = EXR*EI + EXI*ER
               EXR = EXRTMP
               TR = TR - PHI(I) * EXR
               TI = TI - PHI(I) * EXI
   10       CONTINUE
            SPCA(J) = SPCA(J)/(TR*TR + TI*TI)
         END IF
   20 CONTINUE
      RETURN
      END
*UAS
      SUBROUTINE UAS (Y, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE
C     SPECTRUM ESTIMATION (SHORT CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,VAR,YMEAN
      INTEGER
     +   IAR,IPRT,LACOV,LAG,LAGMAX,LAIC,LDSMIN,LDSTAK,LPCV,LPHI,
     +   LSPC,LWORK,NF,NPRT
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),AIC(101),FREQ(101),FTEST(2,100),PHI(100),SPCA(101),
     +   SPCF(101),WORK(101),XAXIS(207),YAXIS(207)
      INTEGER
     +   ISORT(101),ISYM(207)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVF,IPRINT,PARZEN,SETLAG,UASDV,UASER
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS.
C     REAL AIC(101)
C        THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE
C        SPECTRUM ESTIMATES ARE TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     REAL FTEST(2, 100)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 .NE. 0, ERRORS HAVE BEEN DETECTED
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISYM(207)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE COVARIANCE ARRAYS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER LSPC
C         THE LENGTH OF THE SPECTRUM ARRAYS.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR WORK.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE TYPE OF WINDOW TO BE USED.
C     REAL PHI(100)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL SPCA(101)
C        THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCF(101)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED MODEL.
C     REAL WORK(101)
C        A REAL WORK AREA USED FOR THE LAG WINDOWS AND FOR
C        COMPUTING THE AUTOREGRESSIVE COEFFICIENTS.
C     REAL XAXIS(207)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL Y(N)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YAXIS(207)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'U',       'A',       'S',       ' ',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .FALSE.
C
      LAG = 0
      IAR = 0
      NF = 101
      FMIN = 0.0E0
      FMAX = 0.5E0
      NPRT = -1
      LDSTAK = 0
      LDSMIN = 0
C
C     SET THE MAXIMUM NUMBER OF LAGS TO BE USED.
C
      CALL SETLAG(N, LAGMAX)
C
C     CALL ERROR CHECKING ROUTINE
C
      CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV,
     +   NF, LDSTAK, LDSMIN, N, N, OPTION)
C
      IF (IERR.NE.0) THEN
         IERR = 1
         CALL IPRINT (IPRT)
         WRITE (IPRT, 1000)
         RETURN
      END IF
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LPCV = 207
      LSPC = 101
      LPHI = 100
      LAIC = 101
      LACOV = 101
      LWORK = 101
C
      ALPHA = .95E0
      DELTA = 1.0E0
C
C     COMPUTE AUTOCOVARIANCES
C
      CALL ACVF (Y, N, YMEAN, ACOV, LAGMAX, LACOV)
C
C     CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES.
C
      CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX, FREQ,
     +   N, LAGMAX, FTEST, AIC, WORK, LACOV, LWORK, DELTA, ISORT,
     +   ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR,
     +   PARZEN, NMSUB)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   22H       CALL UAS (Y, N))
      END
*UASF
      SUBROUTINE UASF (YFFT, N, LYFFT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE
C     SPECTRUM ESTIMATION USING THE FFT (SHORT CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LDSTAK,LYFFT,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,VAR,YMEAN
      INTEGER
     +   IAR,IFP,IPRT,LACOV,LAG,LAGMAX,LAIC,LDSMIN,LPCV,LPHI,LSPC,
     +   LWORK,NALL0,NF,NFFT,NPRT,WORK
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),AIC(101),FREQ(101),FTEST(2,100),PHI(100),RSTAK(12),
     +   SPCA(101),SPCF(101),XAXIS(207),YAXIS(207)
      INTEGER
     +   ISORT(101),ISTAK(12),ISYM(207)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVFF,IPRINT,LDSCMP,PARZEN,SETESL,SETLAG,STKCLR,STKSET,
     +   UASDV,UASER
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISYM(1),ISORT(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS.
C     REAL AIC(101)
C        THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE
C        SPECTRUM ESTIMATES ARE TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     REAL FTEST(2, 100)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 .NE. 0, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LSPC
C         THE LENGTH OF THE SPECTRUM ARRAYS.
C     INTEGER ISYM(207)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE COVARIANCE ARRAYS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER LWORK
C        THE LENGTH OF THE WORK ARRAY.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT
C        THIS ROUTINE WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE TYPE OF WINDOW TO BE USED.
C     REAL PHI(100)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCA(101)
C        THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCF(101)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE.
C     INTEGER WORK
C        THE STARTING LOCATION IN RSTAK FOR
C        THE WORK VECTOR.
C     REAL XAXIS(207)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YAXIS(207)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'U',       'A',       'S',       'F',       ' ',       ' '/
C
      IFP = 3
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .TRUE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .FALSE.
C
      LAG = 0
      IAR = 0
      NF = 101
      FMIN = 0.0E0
      FMAX = 0.5E0
      NPRT = -1
C
C     SET THE MAXIMUM NUMBER OF LAGS TO BE USED.
C
      CALL SETLAG(N, LAGMAX)
C
C     SET LENGTH OF EXTENDED SERIES
C
      CALL SETESL(N+LAGMAX, 4, NFFT)
C
      CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN)
C
      CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV,
     +   NF, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION)
C
      IF (IERR.NE.0) THEN
         IERR = 1
         CALL IPRINT (IPRT)
         WRITE (IPRT, 1000)
         RETURN
      END IF
C
C     SET THE SIZE OF THE WORK AREA
C
      CALL STKSET(LDSTAK, 4)
C
C     SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LPCV = 207
      LSPC = 101
      LPHI = 100
      LAIC = 101
      LACOV = 101
      LWORK = NFFT
C
      ALPHA = 0.95E0
      DELTA = 1.0E0
C
C     SUBDIVIDE THE WORK AREA
C
      WORK = STKGET(LWORK, IFP)
C
C     COMPUTE AUTOCOVARIANCES
C
      CALL ACVFF (YFFT, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV, LYFFT,
     +   RSTAK(WORK), LWORK)
C
C     CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES.
C
      CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX, FREQ,
     +   N, LAGMAX, FTEST, AIC, RSTAK(WORK), LACOV, LWORK, DELTA, ISORT,
     +   ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR,
     +   PARZEN, NMSUB)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL UASF (YFFT, N, LYFFT, LDSTAK)')
      END
*UASFS
      SUBROUTINE UASFS (YFFT, N, LYFFT, LDSTAK, IAR, PHI, LAGMAX, LAG,
     +  NF, FMIN, FMAX, NPRT, SPCA, SPCF, FREQ)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE
C     SPECTRUM ESTIMATION USING THE FFT (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN
      INTEGER
     +   IAR,LAG,LAGMAX,LDSTAK,LYFFT,N,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),PHI(*),SPCA(*),SPCF(*),YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMN,FMX,VAR,YMEAN
      INTEGER
     +   ACOV,AIC,FTEST,IA,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAIC,
     +   LDSMIN,LPCV,LPHI,LSPC,LWORK,NALL0,NFFT,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVFF,AMEAN,IPRINT,LDSCMP,PARZEN,SETESL,STKCLR,STKSET,
     +   UASDV,UASER,UASVAR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ACOV
C        THE STARTING LOCATION IN RSTAK FOR THE ARRAY OF
C        THE AUTOCOVARIANCE ARRAY.
C     INTEGER AIC
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY CONTAINING THE AIC.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE
C        SPECTRUM ESTIMATES ARE TO BE COMPUTED.
C     REAL FMN, FMX
C        THE MAXIMUM AND MINIMUM FREQUENCY ACTUALLY USED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     INTEGER FTEST
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IA
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON WHETHER OR NOT THE MODEL ORDER IS TO BE SELECTED OR
C        HAS BEEN PROVIDED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 .NE. 0, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION IN ISTAK FOR
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN ISTAK FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE COVARIANCE ARRAYS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER LSPC
C         THE LENGTH OF THE SPECTRUM ARRAYS.
C     INTEGER LWORK
C        THE ACTUAL LENGTH OF THE WORK ARRAY.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS OUTSTANDING WHEN THIS ROUTINE
C        WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE TYPE OF WINDOW TO BE USED.
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCA(NF)
C        THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCF(NF)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE STACK FOR
C        THE WORK ARRAY.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN RSTAK FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN RSTAK FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'U',       'A',       'S',       'F',       'S',       ' '/
C
      IFP = 3
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .TRUE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .TRUE.
C
C     SET EXTENDED SERIES LENGTH
C
      CALL SETESL(N+LAGMAX, 4, NFFT)
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
      IA = 1
      IF (IAR .NE. 0) IA = 0
C
      CALL LDSCMP(7, 0, IO*(2*NF+5), 0, 0, 0, 'S',
     +   LAGMAX+1+NFFT+IA*(3*LAGMAX+1)+IO*(4*NF+10), LDSMIN)
C
      CALL UASER(NMSUB, N, YFFT, IAR, PHI, LAGMAX, LAG, LACOV,
     +   NF, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION)
C
    5 IF (IERR.NE.0) THEN
         IERR = 1
         CALL IPRINT (IPRT)
         WRITE (IPRT, 1000)
         RETURN
      END IF
C
C     SET SIZE OF WORK AREA.
C
      CALL STKSET (LDSTAK, 4)
C
C     SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LSPC = NF
      LPCV = 2*NF + 5
      LPHI = LAGMAX
      LACOV = LAGMAX + 1
      LWORK = NFFT
C
      FMN = MAX(FMIN, 0.0E0)
      FMX = MIN(FMAX, 0.5E0)
      IF (FMN.GE.FMX) THEN
        FMN = 0.0E0
        FMX = 0.5E0
      END IF
C
      ALPHA = 0.95E0
      DELTA = 1.0E0
C
      IF (IAR.GE.1) THEN
C
C     USER HAS CHOSEN ORDER AND SUPPLIED COEFFICIENTS.
C     COMPUTE RESIDUAL VARIANCE.
C
         CALL AMEAN(YFFT, N, YMEAN)
         CALL UASVAR (YFFT, YMEAN, N, IAR, PHI, VAR)
      END IF
C
C     COMPUTE AUTOCOVARIANCES
C
      ACOV = STKGET(LACOV, IFP)
      WORK = STKGET(LWORK, IFP)
C
      CALL ACVFF (YFFT, N, NFFT, YMEAN, RSTAK(ACOV), LAGMAX, LAGMAX+1,
     +   LYFFT, RSTAK(WORK), NFFT)
C
C     SET UP ADDITIONAL STACK WORK AREA, IF NEEDED.
C
      IF (IAR.EQ.0) THEN
         LAIC = LAGMAX+1
         AIC = STKGET(LAIC, IFP)
         FTEST = STKGET(2*LAGMAX, IFP)
      ELSE
         LAIC = LWORK
         AIC = WORK
         FTEST = WORK
      END IF
      IF (NPRT.NE.0) THEN
         XAXIS = STKGET(LPCV, IFP)
         YAXIS = STKGET(LPCV, IFP)
         ISYM = STKGET(LPCV, 2)
         ISORT = ISYM
      ELSE
         XAXIS = WORK
         YAXIS = WORK
         ISYM = WORK
         ISORT = WORK
      END IF
C
      IF (IERR.EQ.1) GO TO 5
C
C     CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES.
C
      CALL UASDV(RSTAK(ACOV), SPCA, SPCF, LSPC, IAR, PHI, NF, FMN,
     +   FMX, FREQ, N, LAGMAX, RSTAK(FTEST), RSTAK(AIC), RSTAK(WORK),
     +   LACOV, LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS),
     +   RSTAK(YAXIS), LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, PARZEN,
     +   NMSUB)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL UASFS (YFFT, N, LYFFT, LDSTAK,'/
     + '      +            IAR, PHI, LAGMAX, LAG, NF, FMIN, FMAX, NPRT'/
     + '      +            SPCA, SPCF, FREQ)')
      END
*UASORD
      SUBROUTINE UASORD (SPCF, SPCA, SPCFMN, SPCFMX, SPCAMN, SPCAMX,
     +   FREQ, NF, XAXIS, YAXIS, ISYM, NPTS, ISPC, LPCV, NSPCF, NSPCA,
     +   BW, ALOW, AUP, XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRUM PLOTS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   ALOW,AUP,BW,SPCAMN,SPCAMX,SPCFMN,SPCFMX,XPLTMN,XPLTMX,YPLTMN,
     +   YPLTMX
      INTEGER
     +   ISPC,LPCV,NF,NPRT,NPTS,NSPCA,NSPCF
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),SPCA(ISPC),SPCF(ISPC),XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
C
C  LOCAL SCALARS
      REAL
     +   CILOW,CIMID,CIUP,YMAX
      INTEGER
     +   I,ISPCA,ISPCF
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SPPLTC,SPPLTD,SPPLTL
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10,MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALOW
C        THE FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS.
C     REAL AUP
C        THE FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS.
C     REAL BW
C        THE BANDWIDTH.
C     REAL CILOW, CIMID, CIUP
C        THE Y AXIS VALUES FOR THE LOWER, MID AND UPPER CONFIDENCE
C        INTERVAL POINTS.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER ISPC
C         THE LENGTH OF THE SPECTRUM ARRAYS.
C     INTEGER ISPCA, ISPCF
C        THE INDEX FOR THE FOURIER AND AUTOREGRESSIVE  ESTIMATES,
C        RESPECTIVELY.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     INTEGER NSPCA, NSPCF
C        THE NUMBER OF VALID SPECTRUM ESTIMATES FOR THE AUTOREGRESSIVE
C        AND FOURIER SPECTRUMS, RESPECTIVELY.
C     REAL SPCA(ISPC)
C        THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCAMN, SPCAMX
C        THE MINIMUM AND MAXIMUM AUTOREGRESSIVE SPECTRUM VALUE TO BE
C        PLOTTED.
C     REAL SPCF(ISPC)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL SPCFMN, SPCFMX
C        THE MINIMUM AND MAXIMUM FOURIER SPECTRUM VALUE TO BE PLOTTED.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMAX
C        THE MAXIMUM  ACTUAL SPECTRUM VALUE (IN DECIBLES) TO BE PLOTTED.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAYIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C
      ISPCF = 0
      ISPCA = NSPCF
C
      IF (NPRT.GE.1) GO TO 30
C
C     SET VARIOUS Y AXIS VALUES FOR DECIBLE PLOTS
C
      CALL SPPLTD (MIN(SPCFMN, SPCAMN), MAX(SPCFMX, SPCAMX),
     +   ALOW, AUP, YPLTMN, YPLTMX, CILOW, CIMID, CIUP, YMAX)
C
C     SET CO-ORDINATES FOR DECIBLE PLOTS
C
      DO 20 I = 1, NF
         IF (SPCF(I) .LT. SPCFMN) GO TO 10
         ISPCF = ISPCF + 1
         XAXIS(ISPCF) = FREQ(I)
         YAXIS(ISPCF) = 10.0E0 * LOG10(SPCF(I)) - YMAX
         ISYM(ISPCF) = 1
C
   10    IF (SPCA(I) .LT. SPCAMN) GO TO 20
         ISPCA = ISPCA + 1
         XAXIS(ISPCA) = FREQ(I)
         YAXIS(ISPCA) = 10.0E0 * LOG10(SPCA(I)) - YMAX
         ISYM(ISPCA) = 2
   20 CONTINUE
C
      GO TO 70
   30 CONTINUE
C
C     SET VARIOUS Y AXIS VALUES FOR LOG PLOTS
C
      CALL SPPLTL (MIN(SPCFMN, SPCAMN), MAX(SPCFMX, SPCAMX),
     +   ALOW, AUP, YPLTMN, YPLTMX, CILOW, CIMID, CIUP)
C
C     SET CO-ORDINATES FOR LOG PLOTS
C
      DO 60 I = 1, NF
         IF (SPCF(I) .LT. SPCFMN) GO TO 50
         ISPCF = ISPCF + 1
         XAXIS(ISPCF) = FREQ(I)
         YAXIS(ISPCF) = SPCF(I)
         ISYM(ISPCF) = 1
C
   50    IF (SPCA(I) .LT. SPCAMN) GO TO 60
         ISPCA = ISPCA + 1
         XAXIS(ISPCA) = FREQ(I)
         YAXIS(ISPCA) = SPCA(I)
         ISYM(ISPCA) = 2
   60 CONTINUE
C
   70 CONTINUE
C
      NPTS = NSPCA + NSPCF
C
C     SET CO-ORDINATES FOR BANDWIDTH AND CONFIDENCE INTERVAL.
C
      CALL SPPLTC (XAXIS, YAXIS, ISYM, NPTS, XPLTMN, XPLTMX, BW, CILOW,
     +   CIMID, CIUP, LPCV)
C
      RETURN
      END
*UASOUT
      SUBROUTINE UASOUT (XAXIS, YAXIS, ISYM, NPTS, BW, IDF, LAG,
     +   IAR, PHI, ISPCER, LPCV, XPLTMN, XPLTMX, YPLTMN, YPLTMX,
     +   FTEST, AIC, LAIC, VAR, NPRT, LAGMAX, AICPRT, N, NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES THE SPECTRUM PLOTS FOR THE
C     AUTOREGRESSIVE SPECTRUM ESTIMATES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   BW,VAR,XPLTMN,XPLTMX,YPLTMN,YPLTMX
      INTEGER
     +   IAR,IDF,ISPCER,LAG,LAGMAX,LAIC,LPCV,N,NPRT,NPTS
      LOGICAL
     +   AICPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   AIC(LAIC),FTEST(2,LAGMAX),PHI(LAGMAX),XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      REAL
     +   XMN,XMX,YMN,YMX
      INTEGER
     +   ILOG,IPRT
      LOGICAL
     +   ERROR
C
C  LOCAL ARRAYS
      REAL
     +   PRHO(1)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AOSLST,IPRINT,PPLMT,PPMN,VERSP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL AIC(LAIC)
C        THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER.
C     LOGICAL AICPRT
C        AN INDICATOR VARIABLE USED TO DETERMINE IF THE AKIAKE
C        INFORMATION CRITERIA AND CHI SQUARED STATISTICS SHOULD
C        BE PRINTED.
C     REAL BW
C        THE BANDWIDTH.
C     LOGICAL ERROR
C        AN ERROR FLAG
C     REAL FTEST(2,LAGMAX)
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER IDF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     INTEGER IPRT
C        THE LOGICAL UNIT NUMBER FOR THE OUTPUT.
C     INTEGER ISPCER
C        A VARIABLE USED TO DESIGNATE AN ERROR IN THE SPECTRAL
C        ESTIMATES.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR THE FOURIER SPECTRUM.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED
C        ORDER.
C     REAL PRHO(1)
C        A DUMMY VARIABLE.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE FOR ORDER IAR.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRAL PLOT.
C     REAL XMN, XMX
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRAL PLOT.
C     REAL YMN, YMX
C        *
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
C     SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH.
C
      CALL IPRINT (IPRT)
C
      IF (.NOT. AICPRT) GO TO 5
C
C     PRINT AUTOREGRESSIVE MODEL ORDER SELECTION STATISTICS
C
      CALL VERSP(.TRUE.)
      WRITE(IPRT, 1007)
      CALL AOSLST (PRHO, AIC, FTEST, LAGMAX, LAIC, IAR, PHI, VAR,
     +   .FALSE., N)
      WRITE (IPRT, 1001)
C
    5 CONTINUE
      CALL VERSP(.TRUE.)
C
      WRITE(IPRT, 1002) LAG, BW, IDF
      WRITE(IPRT, 1000) IAR
      IF (ISPCER .EQ. 0) GO TO 10
      WRITE(IPRT, 1006)
      RETURN
C
   10 CONTINUE
      IF (NPRT.LE.0) THEN
        ILOG = 0
      ELSE
        ILOG = 1
      END IF
C
      CALL PPLMT(YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, YPLTMN,
     +  YPLTMX, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, ERROR, NMSUB,
     +  .FALSE.)
      IF (.NOT.ERROR)
     +   CALL PPMN (YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, 1, ISYM,
     +    LPCV, 0, -1, YMN, YMX, XMN, XMX, .FALSE., ILOG)
      IF (XPLTMN .NE. 0.0E0 .OR. XPLTMX .NE. 0.5E0) RETURN
      WRITE (IPRT, 1004)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (11H AND ORDER , I2, 28H AUTOREGRESSIVE SPECTRUM (.))
 1001 FORMAT ('1')
 1002 FORMAT (44H FOURIER SPECTRUM (+) (LAG WIND. TRUNC. PT.=, I5,
     +   1X, 5H/ BW=, F6.4, 1X, 6H/ EDF=, I6, ')')
 1004 FORMAT(5H+FREQ/
     +   7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X,
     +   2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X,
     +   6H2.2222, 4X, 2H2.)
C1005 FORMAT(5H+FREQ/
C    1   7H PERIOD, 9X, 3HINF, 7X, 3H10., 4X, 2H5., 8X, 6H3.3333, 4X,
C    2   3H2.5, 4X, 2H2.)
 1006 FORMAT(//
     +   56H ** THE PLOT HAS BEEN SUPRESSED BECAUSE FEWER THAN    **/
     +   56H ** FOUR VALID (POSITIVE) SPECTRAL ESTIMATES COULD BE **/
     +   56H ** COMPUTED.                                         **)
 1007 FORMAT (/42H AUTOREGRESSIVE ORDER SELECTION STATISTICS/)
      END
*UASS
      SUBROUTINE UASS (Y, N, IAR, PHI, LAGMAX, LAG, NF, FMIN, FMAX,
     +   NPRT, SPCA, SPCF, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE
C     SPECTRUM ESTIMATION (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN
      INTEGER
     +   IAR,LAG,LAGMAX,LDSTAK,N,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),PHI(*),SPCA(*),SPCF(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMN,FMX,VAR,YMEAN
      INTEGER
     +   ACOV,AIC,FTEST,IA,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAIC,
     +   LDSMIN,LPCV,LPHI,LSPC,LWORK,NALL0,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UASDV,UASER,
     +   UASVAR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ACOV
C        THE STARTING LOCATION IN RSTAK FOR THE ARRAY OF
C        THE AUTOCOVARIANCE ARRAY.
C     INTEGER AIC
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY CONTAINING THE AIC.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE
C        SPECTRUM ESTIMATES ARE TO BE COMPUTED.
C     REAL FMN, FMX
C        THE MAXIMUM AND MINIMUM FREQUENCY ACTUALLY USED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     INTEGER FTEST
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IA
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON WHETHER OR NOT THE MODEL ORDER IS TO BE SELECTED OR
C        HAS BEEN PROVIDED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 .NE. 0, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION IN ISTAK FOR
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN ISTAK FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE COVARIANCE ARRAYS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER LSPC
C         THE LENGTH OF THE SPECTRUM ARRAYS.
C     INTEGER LWORK
C        THE LENGTH OF THE WORK ARRAY.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS OUTSTANDING WHEN THIS ROUTINE
C        WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE TYPE OF WINDOW TO BE USED.
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCA(NF)
C        THE ARRAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCF(NF)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE STACK FOR
C        THE WORK ARRAY.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN RSTAK FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL Y(N)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN RSTAK FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'U',       'A',       'S',       'S',       ' ',       ' '/
C
      IFP = 3
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(4) = .TRUE.
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
      IA = 1
      IF (IAR .NE. 0) IA = 0
C
      CALL LDSCMP(7, 0, IO*(2*NF+5), 0, 0, 0, 'S',
     +   2*LAGMAX+2+IA*(3*LAGMAX+1)+IO*(4*NF+10), LDSMIN)
C
C     CALL ERROR CHECKING ROUTINE
C
      CALL UASER(NMSUB, N, Y, IAR, PHI, LAGMAX, LAG, LACOV,
     +   NF, LDSTAK, LDSMIN, N, N, OPTION)
C
   10 IF (IERR.NE.0) THEN
         IERR = 1
         CALL IPRINT (IPRT)
         WRITE (IPRT, 1000)
         RETURN
      END IF
C
C     SET SIZE OF WORK AREA.
C
      CALL STKSET (LDSTAK, 4)
C
C     SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LSPC = NF
      LPCV = 2*NF + 5
      LPHI = LAGMAX
      LACOV = LAGMAX + 1
      LWORK = LAGMAX+1
C
      FMN = MAX(FMIN, 0.0E0)
      FMX = MIN(FMAX, 0.5E0)
      IF (FMN.GE.FMX) THEN
        FMN = 0.0E0
        FMX = 0.5E0
      END IF
C
      ALPHA = 0.95E0
      DELTA = 1.0E0
C
C     COMPUTE AUTOCOVARIANCES
C
      ACOV = STKGET(LACOV, IFP)
C
      CALL ACVF (Y, N, YMEAN, RSTAK(ACOV), LAGMAX, LACOV)
C
      IF (IAR.GE.1) THEN
C
C     USER HAS CHOSEN ORDER AND SUPPLIED COEFFICIENTS.
C     COMPUTE RESIDUAL VARIANCE.
C
         CALL UASVAR (Y, YMEAN, N, IAR, PHI, VAR)
      END IF
C
C     SET UP ADDITIONAL STACK WORK AREA, IF NEEDED.
C
      WORK = STKGET(LWORK, IFP)
C
      IF (IAR.EQ.0) THEN
         LAIC = LAGMAX+1
         AIC = STKGET(LAIC, IFP)
         FTEST = STKGET(2*LAGMAX, IFP)
      ELSE
         LAIC = LWORK
         AIC = WORK
         FTEST = WORK
      END IF
      IF (NPRT.EQ.0) THEN
         XAXIS = WORK
         YAXIS = WORK
         ISYM = WORK
         ISORT = WORK
      ELSE
         XAXIS = STKGET(LPCV, IFP)
         YAXIS = STKGET(LPCV, IFP)
         ISYM = STKGET(LPCV, 2)
         ISORT = ISYM
      END IF
C
      IF (IERR.EQ.1) GO TO 10
C
C     CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES.
C
      CALL UASDV(RSTAK(ACOV), SPCA, SPCF, LSPC, IAR, PHI, NF, FMN,
     +   FMX, FREQ, N, LAGMAX, RSTAK(FTEST), RSTAK(AIC), RSTAK(WORK),
     +   LACOV, LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS),
     +   RSTAK(YAXIS), LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, PARZEN,
     +   NMSUB)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     + '       CALL UASS (Y, N,'/
     + '      +           IAR, PHI, LAGMAX, LAG, NF, FMIN, FMAX, NPRT,'/
     + '      +           SPCA, SPCF, FREQ, LDSTAK)')
      END
*UASVAR
      SUBROUTINE UASVAR (Y, YMEAN, N, IAR, PHI, VAR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE VARIANCE FOR A GIVEN SERIES
C     AND AUTOREGRESSIVE MODEL.
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
      REAL
     +   VAR,YMEAN
      INTEGER
     +   IAR,N
C
C  ARRAY ARGUMENTS
      REAL
     +   PHI(IAR),Y(N)
C
C  LOCAL SCALARS
      REAL
     +   RES,RSS
      INTEGER
     +   I,IAR1,J,K
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
C     INTEGER IAR1
C        THE VALUE IAR + 1.
C     INTEGER J, K
C        INDEX VALUES.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     REAL PHI(IAR)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL RES
C        *
C     REAL RSS
C        THE ONE STEP PREDICTION RESIDUAL SUM OF SQUARES.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE.
C     REAL Y(N)
C         THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
      RSS = 0.0E0
      IAR1 = IAR+1
      DO 20 I = IAR1, N
         RES = Y(I) - YMEAN
         DO 10 J = 1, IAR
            K = I-J
            RES = RES - PHI(J) * (Y(K)-YMEAN)
   10    CONTINUE
         RSS = RSS + RES*RES
   20 CONTINUE
C
      VAR = RSS / (N-IAR1)
C
      RETURN
C
      END
*UASV
      SUBROUTINE UASV (ACOV, LAGMAX, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE
C     SPECTRUM ESTIMATION WHEN THE ACVF HAVE PREVIOUSLY BEEN
C     COMPUTED AND STORED (SHORT CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
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
     +   LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,VAR
      INTEGER
     +   IAR,IPRT,LACOV,LAG,LAIC,LDSMIN,LDSTAK,LPCV,LPHI,LSPC,
     +   LWORK,NF,NPRT
C
C  LOCAL ARRAYS
      REAL
     +   AIC(101),FREQ(101),FTEST(2,100),PHI(100),SPCA(101),SPCF(101),
     +   WORK(101),XAXIS(207),YAXIS(207)
      INTEGER
     +   ISORT(101),ISYM(207)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PARZEN,UASDV,UASER
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LAGMAX+1)
C        THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS.
C     REAL AIC(101)
C        THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE
C        SPECTRUM ESTIMATES ARE TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     REAL FTEST(2, 100)
C        THE ARRAY CONTAINING THE F RATIO AND F TEST.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 .NE. 0, ERRORS HAVE BEEN DETECTED
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISYM(207)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE COVARIANCE ARRAYS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER LSPC
C         THE LENGTH OF THE SPECTRUM ARRAYS.
C     INTEGER LWORK
C        THE LENGTH OF THE WORK ARRAY.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE TYPE OF WINDOW TO BE USED.
C     REAL PHI(100)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL SPCA(101)
C        THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCF(101)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE.
C     REAL WORK(101)
C        A WORK AREA USED FOR THE LAG WINDOWS AND FOR
C        COMPUTING THE AUTOREGRESSIVE COEFFICIENTS.
C     REAL XAXIS(207)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YAXIS(207)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'U',       'A',       'S',       'V',       ' ',       ' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .TRUE.
      OPTION(4) = .FALSE.
C
      LAG = 0
      IAR = 0
      NF = 101
      FMIN = 0.0E0
      FMAX = 0.5E0
      NPRT = -1
      LACOV = LAGMAX+1
      LDSTAK = 0
      LDSMIN = 0
C
C     CALL ERROR CHECKING ROUTINE
C
      CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV,
     +   NF, LDSTAK, LDSMIN, N, N, OPTION)
C
      IF (IERR.NE.0) THEN
         IERR = 1
         CALL IPRINT (IPRT)
         WRITE (IPRT, 1000)
         RETURN
      END IF
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      LPCV = 207
      LAIC = 101
      LSPC = 101
      LPHI = 100
      LWORK = 101
C
      ALPHA = 0.95E0
      DELTA = 1.0E0
C
C     CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES.
C
      CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX, FREQ,
     +   N, LAGMAX, FTEST, AIC, WORK, LACOV, LWORK, DELTA, ISORT,
     +   ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR,
     +   PARZEN, NMSUB)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL UASV (ACOV, LAGMAX, N)')
      END
*UASVS
      SUBROUTINE UASVS (ACOV, LAGMAX, Y, N, IAR, PHI, LAG, NF,
     +   FMIN, FMAX, NPRT, SPCA, SPCF, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE
C     SPECTRUM ESTIMATION WHEN THE ACVF HAVE PREVIOUSLY BEEN
C     COMPUTED AND STORED (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN
      INTEGER
     +   IAR,LAG,LAGMAX,LDSTAK,N,NF,NPRT
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),FREQ(*),PHI(*),SPCA(*),SPCF(*),Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMN,FMX,VAR,YMEAN
      INTEGER
     +   AIC,FTEST,IA,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAIC,LDSMIN,
     +   LPCV,LPHI,LSPC,LWORK,NALL0,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UASDV,UASER,
     +   UASVAR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LAGMAX+1)
C        THE ARRAY OF AUTOCOVARIANCE ESTIMATES.
C     INTEGER AIC
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY CONTAINING THE AIC.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE
C        SPECTRUM ESTIMATES ARE TO BE COMPUTED.
C     REAL FMN, FMX
C        THE MAXIMUM AND MINIMUM FREQUENCY ACTUALLY USED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        ESTIMATED.
C     INTEGER FTEST
C        THE STARTING LOCATION IN THE STACK FOR
C        THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED.
C     INTEGER IA
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON WHETHER OR NOT THE MODEL ORDER IS TO BE SELECTED OR
C        HAS BEEN PROVIDED.
C     INTEGER IAR
C        THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN.
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 .NE. 0, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED,
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION IN ISTAK FOR
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN ISTAK FOR
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE COVARIANCE ARRAYS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAIC
C        THE LENGTH OF THE ARRAY AIC.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LPCV
C        THE LENGTH OF THE PLOT CO-ORDINATE VECTORS.
C     INTEGER LPHI
C        THE LENGTH OF THE VECTOR PHI.
C     INTEGER LSPC
C         THE LENGTH OF THE SPECTRUM ARRAYS.
C     INTEGER LWORK
C        THE ACTUAL LENGTH OF THE WORK ARRAY.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF STACK ALLOCATIONS OUTSTANDING WHEN THIS ROUTINE
C        WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES
C        ARE TO BE ESTIMATED.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE TYPE OF WINDOW TO BE USED.
C     REAL PHI(LAGMAX)
C        THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE
C        SELECTED ORDER.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCA(NF)
C        THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES.
C     REAL SPCF(NF)
C        THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES.
C     REAL VAR
C        THE ONE STEP PREDICTION VARIANCE.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE STACK FOR
C        THE WORK ARRAY.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN RSTAK FOR
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL Y(N)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN RSTAK FOR
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'U',       'A',       'S',       'V',       'S',       ' '/
C
      IFP = 3
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(1) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(3) = .TRUE.
      OPTION(4) = .TRUE.
C
      LACOV = LAGMAX+1
C
      IO = 1
      IF (NPRT .EQ. 0) IO = 0
      IA = 1
      IF (IAR .NE. 0) IA = 0
C
      CALL LDSCMP(6, 0, IO*(2*NF+5), 0, 0, 0, 'S',
     +   LAGMAX + 1 + IA*(3*LAGMAX+1) + IO*(4*NF+10), LDSMIN)
C
C     CALL ERROR CHECKING ROUTINE
C
      CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV,
     +   NF, LDSTAK, LDSMIN, N, N, OPTION)
C
    5 IF (IERR.NE.0) THEN
         IERR = 1
         CALL IPRINT (IPRT)
         WRITE (IPRT, 1000)
         RETURN
      END IF
C
C     SET SIZE OF WORK AREA.
C
      CALL STKSET (LDSTAK, 4)
C
C     SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS.
C
      NALL0 = STKST(1)
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      LSPC = NF
      LPCV = 2*NF + 5
      LPHI = LAGMAX
      LWORK = LAGMAX+1
C
      FMN = MAX(FMIN, 0.0E0)
      FMX = MIN(FMAX, 0.5E0)
      IF (FMN.GE.FMX) THEN
        FMN = 0.0E0
        FMX = 0.5E0
      END IF
C
      ALPHA = 0.95E0
      DELTA = 1.0E0
C
      IF (IAR.GE.1) THEN
C
C     USER HAS CHOSEN ORDER AND SUPPLIED COEFFICIENTS.
C     COMPUTE RESIDUAL VARIANCE.
C
         CALL AMEAN (Y, N, YMEAN)
         CALL UASVAR (Y, YMEAN, N, IAR, PHI, VAR)
      END IF
C
C     SET UP ADDITIONAL STACK WORK AREA, IF NEEDED.
C
      WORK = STKGET(LWORK,IFP)
      IF (IAR.EQ.0) THEN
         LAIC = LAGMAX+1
         AIC = STKGET(LAIC, IFP)
         FTEST = STKGET(2*LAGMAX, IFP)
      ELSE
         LAIC = LWORK
         AIC = WORK
         FTEST = WORK
      END IF
      IF (NPRT.EQ.0) THEN
         XAXIS = WORK
         YAXIS = WORK
         ISYM = WORK
         ISORT = WORK
      ELSE
         XAXIS = STKGET(LPCV, IFP)
         YAXIS = STKGET(LPCV, IFP)
         ISYM = STKGET(LPCV, 2)
         ISORT = ISYM
      END IF
C
      IF (IERR.EQ.1) GO TO 5
C
C     CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES.
C
      CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMN,
     +   FMX, FREQ, N, LAGMAX, RSTAK(FTEST), RSTAK(AIC), RSTAK(WORK),
     +   LACOV, LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS),
     +   RSTAK(YAXIS), LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, PARZEN,
     +   NMSUB)
C
      CALL STKCLR(NALL0)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL UASVS (ACOV, LAGMAX, Y, N,'/
     +  '      +            IAR, PHI, LAG, NF, FMIN, FMAX, NPRT,'/
     +  '      +            SPCA, SPCF, FREQ, LDSTAK)')
      END
*UFPARM
      SUBROUTINE UFPARM
      RETURN
      END
*UFSDRV
      SUBROUTINE UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF,
     +   FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK,
     +   DELTA, ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, WINDOW,
     +   NMSUB, LDSMIN, LDSTAK, OPTION, LNLPPA, NFFT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLING ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS .
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS
      INTEGER
     +   ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,LY,N,
     +   NF,NFFT,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),FREQ(*),SPCF(*),WORK(*),XAXIS(*),Y(*),YAXIS(*)
      INTEGER
     +   ISORT(*),ISYM(*),LAGS(*),NLPPA(*)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL WINDOW
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALOW,AUP,BW,DF,FMN,FMX,SPCFMN,SPCFMX,XPLTMN,XPLTMX,YMEAN,
     +   YPLTMN,YPLTMX
      INTEGER
     +   I,ILOG,ISPCER,LAG,LAGLST,NFUSED,NPTS,NSPC,NWUSED
      LOGICAL
     +   NEWPG,UNIVAR
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   LSTLAG
      EXTERNAL LSTLAG
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ACVF,ACVFF,ACVFM,SETFRQ,SPCCK,UFSER,UFSLAG,UFSMN,UFSOUT,
     +   UFSPCV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN,NINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCE.
C     REAL ALOW
C        A FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL AUP
C        A FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS.
C     REAL BW
C        THE BANDWIDTH.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL DF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FMN, FMX
C        THE MAXIMUM AND MINIMUM FREQUENCES ACTUALLY USED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE
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 ILOG
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        ILOG = 0 THE PLOT IS LINEAR/LINEAR, IF
C        ILOG = 1 THE PLOT IS LOG/LINEAR, IF
C        ILOG = 2 THE PLOT IS LINEAR/LOG, AND IF
C        ILOG = 3 THE PLOT IS LOG/LOG.
C     INTEGER ISORT(NF)
C        THE VECTOR USED FOR SORTING.
C     INTEGER ISPCER
C        AN ERROR FLAG USED FOR THE SPECTRUM PLOTS.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAG
C        THE LAG WINDWO TRUNCATION POINT USED FOR A SPECIFIC WINDOW.
C     INTEGER LAGLST
C        THE LAST LAG BEFORE MISSING DATA CAUSED AN ACVF
C        TO BE UNABLE TO BE COMPUTED.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     LOGICAL NEWPG
C        THE LOGICAL VARIABLE USED TO DETERMINE IF OUTPUT
C        WILL BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NFUSED
C        THE NUMBER OF FREQUENCIES ACTUALLY USED.
C     INTEGER NLPPA(LNLPPA)
C        THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NPTS
C        THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED.
C     INTEGER NSPC
C        THE NUMBER OF VALID (POSITIVE) SPECTRUM VALUES.
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     INTEGER NWUSED
C        THE NUMBER OF DIFFERENT BANDWIDTHS ACTUALLY USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     REAL SPCF(ISPCF,NW)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL SPCFMN, SPCFMX
C        THE MINIMUM AND MAXIMUM SPECTRUM VALUE TO BE PLOTTED.
C     LOGICAL UNIVAR
C        THE LOGICAL VARIABLE USED TO DETERMINE IF THE OUTPUT
C        IS FOR UNIVARIATE (TRUE) OR BIVARIATE (FALSE) SPECTRA.
C     EXTERNAL WINDOW
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL WORK(LWORK)
C        THE VECTOR OF LAG WINDOWS.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL Y(LY)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMEAN
C        THE MEAN OF THE OBSERVED TIME SERIES
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IN THE SERIES IS MISSING.  IF Y(I) = YMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
      NFUSED = NF
      IF (OPTION(4)) THEN
        FMN = MAX(FMIN, 0.0E0)
        FMX = MIN(FMAX, 0.5E0)
        IF (FMN.GE.FMX) THEN
          FMN = 0.0E0
          FMX = 0.5E0
        END IF
      ELSE
C
C       SET VARIOUS VALUES FOR SHORT FORMS OF CALL STATEMENT
C
        NPRT = -1
        FMN = 0.0E0
        FMX = 0.5E0
      END IF
C
C     CHECK FOR ERRORS
C
      CALL UFSER(NMSUB, N, LAGMAX, LACOV, NFUSED, ISPCF, NW, LAGS,
     +  LDSTAK, LDSMIN, LY, NFFT, OPTION)
C
      IF (IERR.EQ.1) RETURN
C
C     SET VARIOUS PROGRAM PARAMETERS.
C
      ALPHA = 0.95E0
      DELTA = 1.0E0
C
C     COMPUTE COVARIANCES
C
      LAGLST = LAGMAX
      IF (OPTION(1)) THEN
        CALL ACVFF(Y, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV,
     +   LY, WORK, NFFT)
      ELSE
        IF (.NOT.OPTION(3)) THEN
          IF (OPTION(2)) THEN
            CALL ACVFM(Y, YMISS, N, YMEAN, ACOV, LAGMAX, LAGLST,
     +        NLPPA, LACOV)
          ELSE
            CALL ACVF(Y, N, YMEAN, ACOV, LAGMAX, LACOV)
          END IF
        END IF
      END IF
      IF (OPTION(2) .AND. OPTION(3)) LAGLST = LSTLAG(NLPPA,LAGMAX,LACOV)
C
      IF (LAGLST.GE.1) GO TO 20
C
C     AN ERROR HAS BEEN DETECTED
C
      IERR = 2
      RETURN
C
   20 CONTINUE
C
C     COMPUTE THE VECTOR OF LAG WINDOW TRUNCATION POINTS, ORDERED
C     SMALLEST TO LARGEST.
C
      NWUSED = NW
      IF (.NOT.OPTION(4)) CALL UFSLAG(ACOV, LAGLST, LAGS, N, NW,
     +   NWUSED, LACOV)
C
C     BEGIN COMPUTING FOURIER SPECTRUM FOR SERIES
C
      UNIVAR = .TRUE.
C
      IF (NPRT.GE.1) THEN
        ILOG = 1
      ELSE
        ILOG = 0
      END IF
C
      XPLTMN = FMN
      XPLTMX = FMX
C
C     SET FREQUENCIES FOR THE SPECTRUM.
C
      CALL SETFRQ(FREQ, NFUSED, 2, FMN, FMX, DELTA)
C
C     COMPUTE AND PLOT SPECTRUM VALUES.
C
      NEWPG = .FALSE.
C
      DO 50 I=1,NWUSED
         LAG = LAGS(I)
         ISPCER = 0
         IF (LAG.LE.LAGLST) GO TO 30
         ISPCER = 2
         DF = 0.0E0
         GO TO 40
C
   30    CALL UFSMN(ACOV, NLPPA, LAG, DF, NFUSED, FREQ, ALPHA, BW,
     +              SPCF(1+(I-1)*ISPCF), ALOW, AUP, LACOV, ISPCF,
     +              WINDOW, WORK, LAG, N, DELTA, OPTION(2), LNLPPA)
C
         IF (NPRT.EQ.0) GO TO 50
C
         ISPCER = 0
         CALL SPCCK(SPCF(1+(I-1)*ISPCF), ISORT, NFUSED,
     +              SPCFMN, SPCFMX, NSPC, ISPCER)
C
         IF (ISPCER.NE.0) GO TO 40
C
         CALL UFSPCV(SPCF(1+(I-1)*ISPCF), SPCFMN, SPCFMX,
     +               FREQ, NFUSED, XAXIS, YAXIS, ISYM, NPTS, ISPCF,
     +               NFUSED+5, NSPC, BW, ALOW, AUP,
     +               XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT)
C
   40    CALL UFSOUT(XAXIS, YAXIS, ISYM, NPTS, BW, NINT(DF), LAG,
     +      LAGLST, NEWPG, ISPCER, NFUSED+5, XPLTMN, XPLTMX, YPLTMN,
     +      YPLTMX, ILOG, YAXIS, XAXIS, NPTS, UNIVAR, NMSUB)
C
         NEWPG = .TRUE.
C
   50 CONTINUE
C
      RETURN
C
      END
*UFSER
      SUBROUTINE UFSER(NMSUB, N, LAGMAX, LACOV, NF, ISPCF, NW,
     +    LAGS, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR THE TIME SERIES
C     FOURIER UNIVARIATE SPECTRUM ANALYSIS ROUTINES.
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
     +   ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LYFFT,N,NF,NFFT,NW
C
C  ARRAY ARGUMENTS
      INTEGER
     +   LAGS(*)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,NV
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERR(15)
      CHARACTER
     +   L1(8)*1,LISPCF(8)*1,LLACOV(8)*1,LLAGMX(8)*1,LLAGS(8)*1,
     +   LLDS(8)*1,LLGMX1(8)*1,LLYFFT(8)*1,LN(8)*1,LNF(8)*1,
     +   LNM1(8)*1,LNW(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,EIVII
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR(15)
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 IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     CHARACTER*1 LISPCF(8), LLACOV(8), LLAGMX(8),
C    *   LLAGS(8), LLGMX1(8), LLDS(8), LN(8), LNF(8), LNM1(8),
C    *   LNW(8), LLYFFT(8), L1(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF THE ARGUMENT(S)
C        CHECKED FOR ERRORS.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THE USER CALLED SUBROUTINE.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND WHEN CHECKING VECTOR LAGS.
C     INTEGER NW
C        THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C
C     SET UP NAME ARRAYS
C
      DATA LISPCF(1), LISPCF(2), LISPCF(3), LISPCF(4), LISPCF(5),
     +   LISPCF(6), LISPCF(7), LISPCF(8) /'I','S','P','C','F',' ',' ',
     +   ' '/
      DATA LLACOV(1), LLACOV(2), LLACOV(3), LLACOV(4), LLACOV(5),
     +   LLACOV(6), LLACOV(7), LLACOV(8) /'L','A','C','O','V',' ',' ',
     +   ' '/
      DATA LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5),
     +   LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ',
     +   ' '/
      DATA LLAGS(1), LLAGS(2), LLAGS(3), LLAGS(4), LLAGS(5), LLAGS(6),
     +   LLAGS(7), LLAGS(8) /'L','A','G','S',' ',' ',' ',' '/
      DATA LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5),
     +   LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+',
     +   '1'/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7),
     +   LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/
      DATA LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6),
     +   LNM1(7), LNM1(8) /'N','-','1',' ',' ',' ',' ',' '/
      DATA LNW(1), LNW(2), LNW(3), LNW(4), LNW(5), LNW(6), LNW(7),
     +   LNW(8) /'N','W',' ',' ',' ',' ',' ',' '/
      DATA LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5),
     +   LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ',
     +   ' '/
      DATA L1(1), L1(2), L1(3), L1(4), L1(5), L1(6), L1(7), L1(8) /'1',
     +   ' ',' ',' ',' ',' ',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
      DO 10 I=1,15
         ERR(I) = .FALSE.
   10 CONTINUE
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR(1), LN)
C
      IF (OPTION(4)) THEN
        CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR(6), LNF)
        IF (.NOT.ERR(6))
     +     CALL EISGE(NMSUB, LISPCF, ISPCF, NF, 3, HEAD, ERR(7), LNF)
        CALL EISGE(NMSUB, LNW, NW, 1, 1, HEAD, ERR(8), LNW)
      END IF
C
      IF (.NOT.ERR(1)) THEN
        IF (OPTION(3)) THEN
          CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2),
     +       L1, LNM1)
          IF (.NOT.ERR(2)) THEN
            IF (OPTION(2)) THEN
              CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 8, HEAD,
     +          ERR(3), LLGMX1)
            ELSE
              CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 7, HEAD,
     +          ERR(3), LLGMX1)
            END IF
          END IF
        END IF
        IF (.NOT.ERR(2)) THEN
          IF (OPTION(1))
     +      CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR(4),
     +        LLYFFT)
C
          IF (.NOT.ERR(8)) THEN
           IF (OPTION(4)) THEN
            IF (OPTION(3)) THEN
             CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, LAGMAX, 0, HEAD, 3,
     +         NV, ERR(9), L1, LLAGMX)
            ELSE
             CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, N-1, 0, HEAD, 3, NV,
     +         ERR(9), L1, LNM1)
            END IF
           END IF
C
            IF ((.NOT.ERR(6)) .AND. (.NOT.ERR(9)))
     +         CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(14),
     +            LLDS)
          END IF
        END IF
      END IF
C
      DO 40 I=1,15
         IF (ERR(I)) IERR = 1
   40 CONTINUE
C
      RETURN
C
      END
*UFSEST
      SUBROUTINE UFSEST(ACOV, W, LAG, SPCF, ISPCF, LACOV, LW, NF, FREQ,
     +   DELTA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE SPECTRUM, SPCF, AND
C     THEIR LOWER AND UPPER CONFIDENCE LIMITS, SPCLCL AND SPCUCL,
C     RESPECTIVELY.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   DELTA
      INTEGER
     +   ISPCF,LACOV,LAG,LW,NF
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(LACOV),FREQ(NF),SPCF(ISPCF),W(LW)
C
C  LOCAL SCALARS
      REAL
     +   C,PI,V0,V1,V2
      INTEGER
     +   I,K,KK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCES OF THE SERIES.
C     REAL C
C        A VALUE USED TO COMPUTE THE SPECTRUM VALUES.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER K, KK
C        INDEXING VARIABLES.
C     INTEGER LACOV
C        THE LENGTH OF VECTOR ACOV.
C     INTEGER LAG
C        THE LAG WINDOW TRUCCATION POINT.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     REAL PI
C        THE VALUE OF PI.
C     REAL SPCF(ISPCF)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL V0, V1, V2
C        CONSTANTS USED FOR COMPUTING THE SPECTRUM VALUES.
C     REAL W(LW)
C        THE VECTOR OF LAG WINDOWS.
C
      CALL GETPI(PI)
C
C        COMPUTE THE SPECTRUM AND ITS CONFIDENCE LIMITS.
C
      DO 20 I=1,NF
         C = COS(2.0E0*PI*FREQ(I))
         V0 = 0.0E0
         V1 = 0.0E0
         DO 10 K=1,LAG
            KK = LAG + 1 - K
            V2 = 2.0E0*C*V1 - V0 + W(KK+1)*ACOV(KK+1)
            V0 = V1
            V1 = V2
   10    CONTINUE
         SPCF(I) = DELTA*(ACOV(1)*W(1)+2.0E0*(V1*C-V0))
         IF (SPCF(I).LT.0.0E0) SPCF(I) = 0.0E0
   20 CONTINUE
      RETURN
      END
*UFS
      SUBROUTINE UFS(Y, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS
      INTEGER
     +   IPRT,ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,
     +   LY,NF,NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),FREQ(101),SPCF(101,4),WORK(101),XAXIS(106),
     +   YAXIS(106)
      INTEGER
     +   ISORT(101),ISYM(106),LAGS(4),NLPPA(1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PARZEN,SETLAG,UFSDRV
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE).
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
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 LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISYM(106)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(1)
C        A DUMMY ARRAY WHEN THE SERIES DOES NOT CONTAIN MISSING VALUES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL SPCF(101,4)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL WORK(101)
C        THE VECTOR OF LAG WINDOWS.
C     REAL XAXIS(106)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL Y(N)
C         THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YAXIS(106)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMISS
C        A DUMMY VARIABLE WHEN THE SERIES DO NOT CONTAIN MISSING VALUES
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S',' ',' ',' '/
C
C     SET UP
C
      OPTION(4) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(1) = .FALSE.
C
      LDSTAK = 0
      LDSMIN = 0
C
      ISPCF = 101
      LACOV = 101
      LNLPPA = 1
      LY = N
      LPCV = 106
      LWORK = 101
      NF = 101
      YMISS = 1.0E0
C
C     SET MAXIMUM LAG VALUE TO BE USED.
C     AND NUMBER OF LAG WINDOW TRUNCATION POINTS TO USE.
C
      CALL SETLAG(N, LAGMAX)
      NW = 4
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C     FOR SERIES WITH MISSING DATA.
C
      CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN,
     +   FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA,
     +   ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB,
     +   LDSMIN, LDSTAK, OPTION, LNLPPA, LY)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFS (Y, N)')
      END
*UFSF
      SUBROUTINE UFSF(YFFT, N, LYFFT, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS USING THE FFT (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   LDSTAK,LYFFT,N
C
C  ARRAY ARGUMENTS
      REAL
     +   YFFT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS
      INTEGER
     +   IFP,IPRT,ISPCF,LACOV,LAGMAX,LDSMIN,LNLPPA,LPCV,LWORK,
     +   NALL0,NF,NFFT,NPRT,NW,WORK
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),FREQ(101),RSTAK(12),SPCF(101,4),XAXIS(106),
     +   YAXIS(106)
      INTEGER
     +   ISORT(101),ISYM(106),LAGS(4),NLPPA(1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LDSCMP,PARZEN,SETESL,SETLAG,STKSET,UFSDRV
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE).
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
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 IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP = 3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISYM(106)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR YFFT.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT
C       THIS ROUTINE WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NFFT
C        THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES.
C     INTEGER NLPPA(1)
C        A DUMMY ARRAY WHEN THE SERIES DOES NOT CONTAIN MISSING VALUES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCF(101,4)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WORK.
C     REAL XAXIS(106)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YAXIS(106)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMISS
C        A DUMMY VARIABLE WHEN THE SERIES DO NOT CONTAIN MISSING VALUES
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','F',' ',' '/
C
C     SET UP
C
      OPTION(4) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(1) = .TRUE.
C
C     SET MAXIMUM LAG VALUE TO BE USED.
C     SET EXTENDED SERIES LENGTH.
C     SET NUMBER OF LAG WINDOW TRUNCATION POINTS TO USE.
C
      CALL SETLAG(N, LAGMAX)
      CALL SETESL(N+LAGMAX, 4, NFFT)
      NW = 4
C
      ISPCF = 101
      LACOV = 101
      LNLPPA = 1
      LPCV = 106
      LWORK = NFFT
      NF = 101
      YMISS = 1.0E0
C
C     COMPUTE MIIMUM ALLOWABLE STACK LENGTH
C
      CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN)
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C     SET THE STACK ALLOCATION TYPE.
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS.
C
      IF ((LDSMIN.LE.LDSTAK) .AND. (LDSMIN.GE.7)) THEN
         WORK = STKGET(LWORK,IFP)
      ELSE
         WORK = 1
      END IF
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C     FOR SERIES WITH MISSING DATA.
C
      CALL UFSDRV(YFFT, LYFFT, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF,
     +   FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV,
     +   LWORK, DELTA, ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT,
     +   PARZEN, NMSUB, LDSMIN, LDSTAK, OPTION, LNLPPA, NFFT)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFSF (YFFT, N, LYFFT, LDSTAK)')
      END
*UFSFS
      SUBROUTINE UFSFS(YFFT, N, LYFFT, LDSTAK, NW, LAGS, NF, FMIN, FMAX,
     +   NPRT, SPCF, ISPCF, FREQ)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS USING THE FFT (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ISPCF,LDSTAK,LYFFT,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),SPCF(*),YFFT(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS
      INTEGER
     +   ACOV,I,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAGMAX,LDSMIN,LNLPPA,
     +   LPCV,LWORK,NALL0,NFFT,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12),NLPPA(1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LDSCMP,PARZEN,SETESL,STKCLR,STKSET,UFSDRV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ACOV
C        THE STARTING LOCATION IN RSTAK FOR THE ACVF VECTOR.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM
C        IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM.
C     INTEGER LACOV
C        THE LENGTH OF VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LYFFT
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT
C        THIS ROUTINE WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(1)
C        A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCF(ISPCF,NW)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED
C        FOR EACH LAG WINDOW.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WORK.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS.
C     REAL YFFT(LYFFT)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS.
C     REAL YMISS
C        THE MISSING VALUE CODE FOR THE SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','F','S',' '/
C
C     SET UP
C
      OPTION(4) = .TRUE.
      OPTION(3) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(1) = .TRUE.
C
C     SET MAXIMUM LAG VALUE TO BE USED.
C
      LAGMAX = N - 1
      IF (NW.LE.0) GO TO 20
      LAGMAX = LAGS(1)
      DO 10 I=1,NW
         LAGMAX = MAX(LAGMAX,LAGS(I))
   10 CONTINUE
   20 CONTINUE
      LACOV = LAGMAX + 1
      LNLPPA = 1
C
C     SET EXTENDED SERIES LENGTH
C
      CALL SETESL(N+LAGMAX, 4, NFFT)
C
C     COMPUTE MINIMUM ALLOWABLE STACK LENGTH
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(5, 0, IO*(NF+5), 0, 0, 0, 'S',
     +   LAGMAX+1+NFFT+IO*(2*NF+10), LDSMIN)
C
      LPCV = NF + 5
      LWORK = NFFT
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C     SET THE STACK ALLOCATION TYPE.
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS.
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         ACOV = 1
         WORK = 1
         XAXIS = 1
         YAXIS = 1
         ISYM = 1
         ISORT = 1
      ELSE
         ACOV = STKGET(LACOV,IFP)
         WORK = STKGET(LWORK,IFP)
         IF (NPRT.NE.0) THEN
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
            ISYM = STKGET(LPCV,2)
            ISORT = ISYM
         ELSE
            XAXIS = WORK
            YAXIS = WORK
            ISYM = WORK
            ISORT = ISYM
         END IF
      END IF
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C
      CALL UFSDRV(YFFT, LYFFT, YMISS, RSTAK(ACOV), NLPPA, SPCF, ISPCF,
     +   NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV,
     +   LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS),
     +   RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK,
     +   OPTION, LNLPPA, NFFT)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFSFS (YFFT, N, LYFFT, LDSTAK,'/
     +   '      +            NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +   '      +            SPCF, ISPCF, FREQ)')
      END
*UFSLAG
      SUBROUTINE UFSLAG (ACOV, LAGMAX, LAGS, N, NW, NWUSED, LACOV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE LAG WINDOW TRUNCATION POINTS FOR
C     SPECTRUM ANALYSIS.
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   LACOV,LAGMAX,N,NW,NWUSED
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(LACOV)
      INTEGER
     +   LAGS(NW)
C
C  LOCAL SCALARS
      REAL
     +   ACOVMX,P95LIM
      INTEGER
     +   I,J,K,LAG,NWM1
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,REAL,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED
C     REAL ACOVMX
C        THE MAXIMUM AUTOCOVARIANCE VALUE.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER J, K
C        INDEX VARIABLES.
C     INTEGER LACOV
C        THE LENGTH OF VECTOR ACOV.
C     INTEGER LAG, LAGMAX
C        THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE
C        AUTOCOVARIANCE BEING COMPUTED AND THE MAXIMUM LAG TO BE USED,
C        RESPECTIVELY.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NW
C        THE NUMBER OF DIFFERENT BANDWIDTHS REQUESTED.
C     INTEGER NWM1, NWUSED
C        THE NUMBER OF DIFFERENT BANDWIDTHS MINUS 1, AND THE
C        ACTUAL NUMBER OF BANDWIDTHS ACTUALLY USED.
C     REAL P95LIM
C        THE 95 PERCENT CONFIDENT LIMIT FOR WHITE NOISE.
C
      LAGS(NW) = LAGMAX
      IF (LAGS(NW) .LE. 32) GO TO 30
C
C     COMPUTE 95 PERCENT CONFIDENCE LIMITS ON AUTOCOVARIANCES,
C     ASSUMING WHITE NOISE.
C
      P95LIM = 1.96E0 * ACOV(1) / SQRT(REAL(N))
C
C     CHECK FOR FIRST ACVF EXCEEDING 95 PERCENT LIMIT ON WHITE NOISE
C
      DO 10 I = 1, LAGMAX
         LAG = LAGMAX + 1 - I
         IF (ABS(ACOV(LAG + 1)) .GE. P95LIM) GO TO 30
         LAGS(NW) = LAGS(NW) - 1
   10 CONTINUE
C
C     IF NO ACVF EXCEEDS WHITE NOISE LIMITS, CHECK FOR LARGEST ACVF.
C
      LAGS(NW) = 1
      ACOVMX = ABS(ACOV(2))
      DO 20 LAG = 1, LAGMAX
         IF (ABS(ACOV(LAG + 1)) .LE. ACOVMX) GO TO 20
         LAGS(NW) = LAG
         ACOVMX = ABS(ACOV(LAG + 1))
   20 CONTINUE
C
C     COMPUTE LAG WINDOW TRUNCATION POINTS
C
   30 LAGS(NW) = LAGS(NW) * 3.0E0 / 2.0E0
      IF (LAGS(NW) .LT. 32) LAGS(NW) = 32
      IF (LAGS(NW) .GT. LAGMAX) LAGS(NW) = LAGMAX
      NWUSED = NW
      IF (NW .EQ. 1) RETURN
      NWM1 = NW - 1
      DO 40 I = 1, NWM1
         K = NW - I
         LAGS(K) = LAGS(K + 1) / 2
   40 CONTINUE
C
C     CHECK WHETHER ALL NW LAG WINDOW TRUNCATION POINTS CAN BE USED.
C
      NWUSED = NW
      IF (LAGS(1) .GE. 4) RETURN
C
C     RECONSTURCT -LAGS- VECTOR IF NOT ALL TRUNCATION POINTS ARE
C     TO BE USED
C
      DO 50 I = 2, NW
         NWUSED = NWUSED - 1
         IF (LAGS(I) .GE. 4) GO TO 60
   50 CONTINUE
C
   60 DO 70 I = 1, NWUSED
         J = NW - NWUSED + I
         LAGS(I) = LAGS(J)
   70 CONTINUE
C
      RETURN
      END
*UFSM
      SUBROUTINE UFSM(Y, YMISS, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS WITH MISSING DATA (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   YMISS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN
      INTEGER
     +   IPRT,ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,
     +   LY,NF,NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   ACOV(101),FREQ(101),SPCF(101,4),WORK(101),XAXIS(106),
     +   YAXIS(106)
      INTEGER
     +   ISORT(101),ISYM(106),LAGS(4),NLPPA(101)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ECVF,IPRINT,PARZEN,SETLAG,UFSDRV
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(101)
C        THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE).
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
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 LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISYM(106)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(101)
C        THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL SPCF(101,4)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL WORK(101)
C        THE VECTOR OF LAG WINDOWS.
C     REAL XAXIS(106)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL Y(N)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     REAL YAXIS(106)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMISS
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IN THE SERIES IS MISSING.  IF Y(I) = YMISS,
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','M',' ',' '/
C
C     SET UP
C
      OPTION(4) = .FALSE.
      OPTION(3) = .FALSE.
      OPTION(2) = .TRUE.
      OPTION(1) = .FALSE.
C
      LDSTAK = 0
      LDSMIN = 0
C
      ISPCF = 101
      LACOV = 101
      LNLPPA = 101
      LY = N
      LPCV = 106
      LWORK = 101
      NF = 101
C
C     SET MAXIMUM LAG VALUE TO BE USED.
C     AND NUMBER OF LAG WINDOW TRUNCATION POINTS TO USE.
C
      CALL SETLAG(N, LAGMAX)
      NW = 4
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C     FOR SERIES WITH MISSING DATA.
C
      CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN,
     +   FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA,
     +   ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB,
     +   LDSMIN, LDSTAK, OPTION, LNLPPA, LY)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      IF (IERR.EQ.2) CALL ECVF(NMSUB)
      IERR = 1
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFSM (Y, YMISS, N)')
      END
*UFSMN
      SUBROUTINE UFSMN(ACOV, NLPPA, LAG, DF, NF, FREQ, ALPHA, BW, SPCF,
     +   ALOW, AUP, LACOV, ISPCF, WINDOW, W, LW, N, DELTA, MISS, LNLPPA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND
C     PARTIAL AUTOCORRELATIONS OF A TIME SERIES
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   ALOW,ALPHA,AUP,BW,DELTA,DF
      INTEGER
     +   ISPCF,LACOV,LAG,LNLPPA,LW,N,NF
      LOGICAL
     +   MISS
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(LACOV),FREQ(NF),SPCF(ISPCF),W(LW)
      INTEGER
     +   NLPPA(LNLPPA)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL WINDOW
C
C  EXTERNAL FUNCTIONS
      REAL
     +   PPFCHS
      EXTERNAL PPFCHS
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DFBW,DFBWM,UFSEST
C
C  INTRINSIC FUNCTIONS
      INTRINSIC NINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LACOV)
C        THE AUTOCOVARIANCES OF THE SERIES.
C     REAL ALOW
C        A FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL AUP
C        A FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS.
C     REAL BW
C        THE BANDWIDTH.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL DF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER LACOV
C        THE LENGTH OF VECTOR ACOV.
C     INTEGER LAG
C        THE VARIABLE INDICATING THE LAG VALUE BEING EXAMINED.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LW
C        THE LENGTH OF THE VECTOR W.
C     LOGICAL MISS
C        AN INDICATOR VARIABLE WHICH DESIGNATES WHETHER THERE ARE
C        MISSING VALUES (TRUE) OR NOT (FALSE)
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE TIME SERIES.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(LNLPPA)
C        THE NUMBERS OF LAGGED PRODUCT PAIRS IN EACH ACVF VALUE.
C     REAL SPCF(ISPCF)
C        THE ARRAY IN WHICH THE SPECTRUM IS STORED.
C     REAL W(LW)
C        THE VECTOR OF LAG WINDOWS.
C     EXTERNAL WINDOW
C        THE NAME OF THE WINDOW COMPUTING SUBROUTINE.
C
C     COMPUTE THE WINDOW, EFFECTIVE DEGREES OF FREEDOM AND
C     BANDWIDTH BASED ON THE WINDOW.
C
      CALL WINDOW(LAG, W, LW)
      IF (.NOT.MISS) CALL DFBW(N, LAG, W, LW, DF, BW)
      IF (MISS) CALL DFBWM(N, LAG, W, LW, NLPPA, NLPPA, LNLPPA, DF, BW)
C
C     COMPUTE THE SPECTRUM
C
      CALL UFSEST(ACOV, W, LAG, SPCF, ISPCF, LACOV, LW, NF, FREQ, DELTA)
C
C     COMPUTE -ALPHA- PERCENT POINT FUNCTION VALUE FOR
C     SPECTRUM WINDOW BEING USED.
C
      ALOW = DF/PPFCHS(0.5E0+ALPHA/2.0E0,NINT(DF))
      AUP = DF/PPFCHS(0.5E0-ALPHA/2.0E0,NINT(DF))
C
      RETURN
      END
*UFSMS
      SUBROUTINE UFSMS(Y, YMISS, N, NW, LAGS, NF, FMIN, FMAX, NPRT,
     +   SPCF, ISPCF, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS WITH MISSING DATA (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN,YMISS
      INTEGER
     +   ISPCF,LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),SPCF(*),Y(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA
      INTEGER
     +   ACOV,I,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAGMAX,LDSMIN,LNLPPA,
     +   LPCV,LWORK,LY,NALL0,NLPPA,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ACOV
C        THE STARTING LOCATION IN RSTAK FOR THE ACVF VECTOR.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM
C        IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM.
C     INTEGER LACOV
C        THE LENGTH OF VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT
C        THIS ROUTINE WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA
C        THE STARTING LOCATION IN ISTAK FOR THE ARRAY CONTAINING
C        THE NUMBERS OF LAGGED PRODUCT PAIRS USED FOR EACH ACVF.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCF(ISPCF,NW)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED
C        FOR EACH LAG WINDOW.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WINDOW.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS.
C     REAL Y(N)
C        THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS.
C     REAL YMISS
C        THE MISSING VALUE CODE FOR THE SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','M','S',' '/
C
C     SET UP
C
      OPTION(4) = .TRUE.
      OPTION(3) = .FALSE.
      OPTION(2) = .TRUE.
      OPTION(1) = .FALSE.
C
C     SET MAXIMUM LAG VALUE TO BE USED.
C
      LAGMAX = N - 1
      IF (NW.LE.0) GO TO 20
      LAGMAX = LAGS(1)
      DO 10 I=1,NW
         LAGMAX = MAX(LAGMAX,LAGS(I))
   10 CONTINUE
   20 CONTINUE
      LACOV = LAGMAX + 1
      LNLPPA = LAGMAX + 1
C
C     COMPUTE MINIMUM ALLOWABLE STACK LENGTH
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(6, 0, LAGMAX+1+IO*(NF+5), 0, 0, 0, 'S',
     +   2*LAGMAX+2+IO*(2*NF+10), LDSMIN)
C
      LY = N
      LNLPPA = LACOV
      LPCV = NF + 5
      LWORK = LAGMAX+1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C     SET THE STACK ALLOCATION TYPE.
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS.
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         NLPPA = 1
         ACOV = 1
         WORK = 1
         XAXIS = 1
         YAXIS = 1
         ISYM = 1
         ISORT = 1
      ELSE
         NLPPA = STKGET(LACOV,2)
         ACOV = STKGET(LACOV,IFP)
         WORK = STKGET(LWORK,IFP)
         IF (NPRT.NE.0) THEN
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
            ISYM = STKGET(LPCV,2)
            ISORT = ISYM
         ELSE
            XAXIS = WORK
            YAXIS = WORK
            ISYM = WORK
            ISORT = ISYM
         END IF
      END IF
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C     FOR SERIES WITH MISSING DATA.
C
      CALL UFSDRV(Y, LY, YMISS, RSTAK(ACOV), ISTAK(NLPPA), SPCF, ISPCF,
     +   NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV,
     +   LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS),
     +   RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK,
     +   OPTION, LNLPPA, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      IF (IERR.EQ.2) CALL ECVF(NMSUB)
      IERR = 1
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFSMS (Y, YMISS, N,'/
     +   '      +            NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +   '      +            SPCF, ISPCF, FREQ, LDSTAK)')
      END
*UFSMV
      SUBROUTINE UFSMV(ACOV, NLPPA, LAGMAX, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS WITH MISSING DATA AND USER SUPPLIED
C     ACVF VALUES (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*)
      INTEGER
     +   NLPPA(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS
      INTEGER
     +   IPRT,ISPCF,LACOV,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,LY,NF,
     +   NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   FREQ(101),SPCF(101,4),WORK(101),XAXIS(106),Y(1),YAXIS(106)
      INTEGER
     +   ISORT(101),ISYM(106),LAGS(4)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ECVF,IPRINT,PARZEN,UFSDRV
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LAGMAX+1)
C        THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE).
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
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 LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISYM(106)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(LAGMAX+1)
C        THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL SPCF(101,4)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL WORK(101)
C        THE VECTOR OF LAG WINDOWS.
C     REAL XAXIS(106)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL Y(1)
C        A DUMMY ARRAY.
C     REAL YAXIS(106)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMISS
C        A DUMMY VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','M','V',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(4) = .FALSE.
      OPTION(3) = .TRUE.
      OPTION(2) = .TRUE.
      OPTION(1) = .FALSE.
C
      LDSTAK = 0
      LDSMIN = 0
C
      YMISS = 1.0E0
      LACOV = LAGMAX+1
C
      ISPCF = 101
      LY = 1
      LNLPPA = LACOV
      LPCV = 106
      LWORK = 101
      NF = 101
C
C     SET NUMBER OF LAG WINDOW TRUNCATION POINTS
C
      NW = 4
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C     FOR SERIES WITH MISSING DATA.
C
      CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN,
     +   FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA,
     +   ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB,
     +   LDSMIN, LDSTAK, OPTION, LNLPPA, LY)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      IF (IERR.EQ.2) CALL ECVF(NMSUB)
      IERR = 1
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFSMV (ACOV, NLPPA, LAGMAX, N)')
      END
*UFSMVS
      SUBROUTINE UFSMVS(ACOV, NLPPA, LAGMAX, N, NW, LAGS, NF,
     +   FMIN, FMAX, NPRT, SPCF, ISPCF, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS WITH MISSING DATA (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ISPCF,LAGMAX,LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),FREQ(*),SPCF(*)
      INTEGER
     +   LAGS(*),NLPPA(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS
      INTEGER
     +   IFP,IO,IPRT,ISORT,ISYM,LACOV,LDSMIN,LNLPPA,LPCV,LWORK,LY,
     +   NALL0,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12),Y(1)
      INTEGER
     +   ISTAK(12)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LAGMAX+1)
C        THE AUTOCOVARIANCES OF THE SERIES.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM
C        IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM.
C     INTEGER LACOV
C        THE LENGTH OF THE ACVF VECTORS.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT
C        THIS ROUTINE WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(LAGMAX+1)
C        THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCF(ISPCF,NW)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED
C        FOR EACH LAG WINDOW.
C     INTEGER WORK
C        THE STARTING LOCATION IN RSTAK FOR
C        THE WORK VECTOR.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS.
C     REAL Y(1)
C        A DUMMY ARRAY.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS.
C     REAL YMISS
C        A DUMMY VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','M','V','S'/
C
C     SET UP
C
      OPTION(4) = .TRUE.
      OPTION(3) = .TRUE.
      OPTION(2) = .TRUE.
      OPTION(1) = .FALSE.
C
C     COMPUTE MINIMUM ALLOWABLE STACK LENGTH
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(4, 0, IO*(NF+5), 0, 0, 0, 'S',
     +   LAGMAX+1+IO*(2*NF+10), LDSMIN)
C
      YMISS = 1.0E0
      LACOV = LAGMAX+1
C
      LY = 1
      LNLPPA = LACOV
      LPCV = NF + 5
      LWORK = LAGMAX+1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C     SET THE STACK ALLOCATION TYPE.
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS.
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         WORK = 1
         XAXIS = 1
         YAXIS = 1
         ISYM = 1
         ISORT = 1
      ELSE
         WORK = STKGET(LWORK,IFP)
         IF (NPRT.NE.0) THEN
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
            ISYM = STKGET(LPCV,2)
            ISORT = ISYM
         ELSE
            XAXIS = WORK
            YAXIS = WORK
            ISYM = WORK
            ISORT = ISYM
         END IF
      END IF
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C     FOR SERIES WITH MISSING DATA.
C
      CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN,
     +   FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, LWORK,
     +   DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), RSTAK(YAXIS),
     +   LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK, OPTION,
     +   LNLPPA, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      IF (IERR.EQ.2) CALL ECVF(NMSUB)
      IERR = 1
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL UFSMVS (ACOV, NLPPA, LAGMAX, N,'/
     +  '      +             NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +  '      +             SPCF, ISPCF, FREQ, LDSTAK)')
      END
*UFSOUT
      SUBROUTINE UFSOUT(XAXIS, YAXIS, ISYM, NPTS, BW, IDF, LAG, LAGLST,
     +   NEWPG, ISPCER, LPCV, XPLTMN, XPLTMX, YPLTMN, YPLTMX, ILOG,
     +   PHAS, FREQ, NF, UNIVAR, NMSUB)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES THE FOURIER BIVARIATE SPECTRUM OUTPUT.
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
      REAL
     +   BW,XPLTMN,XPLTMX,YPLTMN,YPLTMX
      INTEGER
     +   IDF,ILOG,ISPCER,LAG,LAGLST,LPCV,NF,NPTS
      LOGICAL
     +   NEWPG,UNIVAR
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),PHAS(NF),XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   PI,XMN,XMX,YMN,YMX
      INTEGER
     +   I,IPRT
      LOGICAL
     +   ERROR
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI,IPRINT,PPLMT,PPMN,VERSP
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL BW
C        THE BANDWIDTH.
C     LOGICAL ERROR
C        AN ERROR FLAG
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER IDF
C        THE EFFECTIVE DEGREES OF FREEDOM.
C     INTEGER IERR
C        THE ERROR FLAG.
C     INTEGER ILOG
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        ILOG = 0 THE PLOT IS LINEAR/LINEAR, IF
C        ILOG = 1 THE PLOT IS LOG/LINEAR, IF
C        ILOG = 2 THE PLOT IS LINEAR/LOG, AND IF
C        ILOG = 3 THE PLOT IS LOG/LOG.
C     INTEGER IPRT
C        THE LOGICAL UNIT NUMBER FOR THE OUTPUT.
C     INTEGER ISPCER
C        A VARIABLE USED TO DESIGNATE AN ERROR IN THE SPECTRUM
C        VALUES.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LAG
C        THE LAG WINDOW TRUNCATION POINT.
C     INTEGER LAGLST
C        THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF EITHER
C        SERIES 1 OR 2 NOT TO BE COMPUTED.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     LOGICAL NEWPG
C        THE LOGICAL VARIABLE USED TO DETERMINE IF OUTPUT
C        WILL BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE CALLING SUBROUTINE.
C     INTEGER NPTS
C        THE NUMBER OF CO-ORDINATES TO BE PLOTTED.
C     REAL PHAS(NF)
C        THE PHASE COMPONENT OF THE BIVARIATE SPECTRA.
C     REAL PI
C        THE VALUE OF PI.
C     LOGICAL UNIVAR
C        THE LOGICAL VARIABLE USED TO DETERMINE IF THE OUTPUT
C        IS FOR UNIVARIATE (TRUE) OR BIVARIATE (FALSE) SPECTRA.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL XMN, XMX
C        *
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMN, YMX
C        *
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS.
C
C      SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH.
C
      CALL IPRINT(IPRT)
C
      CALL GETPI(PI)
C
      IF (NEWPG) WRITE (IPRT,1010)
      IF (ISPCER.LE.1) GO TO 10
      CALL VERSP(.TRUE.)
      WRITE (IPRT,1060) LAGLST, LAG
      RETURN
C
   10 CONTINUE
      CALL VERSP(.TRUE.)
      IF (.NOT.UNIVAR) WRITE (IPRT,1070)
      IF (UNIVAR) WRITE (IPRT,1080)
      WRITE (IPRT,1020) LAG, BW, IDF
      IF (ISPCER.EQ.0) GO TO 20
      WRITE (IPRT,1050)
      GO TO 30
C
   20 CONTINUE
C
C     PRINT PLOTS
C
C     PLOT SQUARED COHERENCY COMPONENT OF SPECTRUM
C
      CALL PPLMT(YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, YPLTMN,
     +  YPLTMX, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, ERROR, NMSUB,
     +  .FALSE.)
      IF (.NOT.ERROR)
     +  CALL PPMN(YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, 1, ISYM,
     +  LPCV, 0, -1, YMN, YMX, XMN, XMX, .FALSE., ILOG)
      IF (XPLTMN.EQ.0.0E0 .AND. XPLTMX.EQ.0.5E0) WRITE (IPRT, 1030)
C
   30 IF (UNIVAR) RETURN
      DO 40 I=1,NF
         XAXIS(I) = FREQ(I)
         XAXIS(NF+I) = FREQ(I)
         YAXIS(I) = PHAS(I)
         IF (PHAS(I).GT.0.0E0) THEN
            YAXIS(NF+I) = PHAS(I) - 2*PI
         ELSE IF (PHAS(I).LT.0.0E0) THEN
            YAXIS(NF+I) = PHAS(I) + 2*PI
         ELSE
            YAXIS(NF+I) = 0.0E0
         END IF
   40 CONTINUE
C
C     PLOT SMOOTHED PHASE COMPONENT OF SPECTRUM
C
      WRITE (IPRT,1010)
      CALL VERSP(.TRUE.)
      WRITE (IPRT,1000)
      WRITE (IPRT,1020) LAG, BW, IDF
      CALL PPLMT(YAXIS, YAXIS, XAXIS, XAXIS, 2*NF, 1, 2*NF, -2*PI, 2*PI,
     +  YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, ERROR, NMSUB, .FALSE.)
      IF (ERROR) THEN
        IERR = 1
      ELSE
        CALL PPMN(YAXIS, YAXIS, XAXIS, XAXIS,
     +            2*NF, 1, 2*NF, 0, ISYM, LPCV,
     +            0, -1, YMN, YMX, XMN, XMX, .FALSE., ILOG)
        IF (XPLTMN.EQ.0.0E0 .AND. XPLTMX.EQ.0.5E0) WRITE (IPRT, 1030)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (50H -- SMOOTHED FOURIER SPECTRUM (PHASE COMPONENT) --)
 1010 FORMAT ('1')
 1020 FORMAT (45H    (PARZEN WINDOW WITH LAG WIND. TRUNC. PT.=, I5, 1X,
     +   5H/ BW=, F6.4, 1X, 6H/ EDF=, I6, ')')
 1030 FORMAT (5H+FREQ/7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X,
     +   6H6.6667, 4X, 2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X,
     +   3H2.5, 7X, 6H2.2222, 4X, 2H2.)
C1040 FORMAT (5H+FREQ/7H PERIOD, 9X, 3HINF, 7X, 3H10., 7X, 2H5., 8X,
C    *   6H3.3333, 4X, 3H2.5, 7X, 2H2.)
 1050 FORMAT (//39H THE PLOT HAS BEEN SUPRESSED BECAUSE NO/
     +   40H POSITIVE SPECTRUM VALUES WERE COMPUTED.)
 1060 FORMAT (//50H THE LARGEST LAG WINDOW TRUNCATION POINT WHICH CAN/
     +   12H BE USED IS , I5, '.'/34H THE SPECTRUM FOR THE REQUESTED LA,
     +   8HG WINDOW, 10H POINT OF , I5, ','/24H THEREFORE, CANNOT BE CO,
     +   7HMPUTED.)
 1070 FORMAT (48H -- SMOOTHED FOURIER SPECTRUM (SQUARED COHERENCY,
     +   46H COMPONENT) (+), 95 PCT. CONFIDENCE LIMITS (.),
     +   38H AND 95 PCT. SIGNIFICANCE LEVEL (-) --)
 1080 FORMAT (32H -- SMOOTHED FOURIER SPECTRUM --)
      END
*UFSPCV
      SUBROUTINE UFSPCV (SPCF, SPCMN, SPCMX, FREQ, NF, XAXIS, YAXIS,
     +   ISYM, NPTS, ISPCF, LPCV, NSPC, BW, ALOW, AUP, XPLTMN, XPLTMX,
     +   YPLTMN, YPLTMX, NPRT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRUM PLOTS.
C
C     WRITTEN BY - JANET R. DONALDSON
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
      REAL
     +   ALOW,AUP,BW,SPCMN,SPCMX,XPLTMN,XPLTMX,YPLTMN,YPLTMX
      INTEGER
     +   ISPCF,LPCV,NF,NPRT,NPTS,NSPC
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(NF),SPCF(ISPCF),XAXIS(LPCV),YAXIS(LPCV)
      INTEGER
     +   ISYM(LPCV)
C
C  LOCAL SCALARS
      REAL
     +   CILOW,CIMID,CIUP,YMAX
      INTEGER
     +   I,ISPCFW
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SPPLTC,SPPLTD,SPPLTL
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ALOW, AUP
C        FACTORS USED TO COMPUTE THE CONFIDENCE INTERVALS.
C     REAL BW
C       THE BANDWIDTH.
C     REAL CILOW, CIMID, CIUP
C        THE Y AXIS VALUES FOR THE LOWER  MID AND UPPER CONFIDENCE
C        INTERVAL POINTS.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISPCFW
C        AN INDEX VARIABLE.
C     INTEGER ISYM(LPCV)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NPTS
C        THE NUMBER OF CO-ORDINATES TO BE PLOTTED.
C     INTEGER NSPC
C        THE NUMBER OF VALID SPECTRUM VALUES.
C     REAL SPCF(ISPCF)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED
C        FOR EACH LAG WINDOW.
C     REAL SPCMN, SPCMX
C        THE MINIMUM AND MAXIMUM SPECTRUM VALUE TO BE PLOTTED.
C     REAL XAXIS(LPCV)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL XPLTMN, XPLTMX
C        THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS.
C     REAL YAXIS(LPCV)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOTS.
C     REAL YMAX
C        THE MAXIMUM ACTUAL SPECTRUM VALUE (IN DECIBELS) TO BE PLOTTED.
C     REAL YPLTMN, YPLTMX
C        THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS.
C
C
      ISPCFW = 0
C
      IF (NPRT .GE. 1) GO TO 30
C
C     SET VARIOUS Y AXIS VALUES FOR DECIBLE PLOTS
C
      CALL SPPLTD (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX,
     +   CILOW, CIMID, CIUP, YMAX)
C
C     SET CO-ORDINATES FOR DECIBLE PLOTS
C
      DO 10 I = 1, NF
         IF (SPCF(I) .LT. SPCMN) GO TO 10
         ISPCFW = ISPCFW + 1
         XAXIS(ISPCFW) = FREQ(I)
         YAXIS(ISPCFW) = 10.0E0 * LOG10(SPCF(I)) - YMAX
         ISYM(ISPCFW) = 1
   10 CONTINUE
C
      GO TO 70
C
   30 CONTINUE
C
C     SET VARIOUS Y AXIS VALUES FOR LOG PLOTS
C
      CALL SPPLTL (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX,
     +   CILOW, CIMID, CIUP)
C
C     SET CO-ORDINATES FOR LOG PLOTS
C
      DO 50 I = 1, NF
         IF (SPCF(I) .LT. SPCMN) GO TO 50
         ISPCFW = ISPCFW + 1
         XAXIS(ISPCFW) = FREQ(I)
         YAXIS(ISPCFW) = SPCF(I)
         ISYM(ISPCFW) = 1
   50 CONTINUE
C
   70 CONTINUE
C
      NPTS = NSPC
C
C     SET CO-ORDINATES FOR BANDWIDTH AND CONFIDENCE INTERVAL.
C
      CALL SPPLTC (XAXIS, YAXIS, ISYM, NPTS, XPLTMN, XPLTMX, BW, CILOW,
     +   CIMID, CIUP, LPCV)
C
      RETURN
      END
*UFSS
      SUBROUTINE UFSS(Y, N, NW, LAGS, NF, FMIN, FMAX, NPRT,
     +   SPCF, ISPCF, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ISPCF,LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   FREQ(*),SPCF(*),Y(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS
      INTEGER
     +   ACOV,I,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAGMAX,LDSMIN,LNLPPA,
     +   LPCV,LWORK,LY,NALL0,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12),NLPPA(1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER ACOV
C        THE STARTING LOCATION IN RSTAK FOR THE ACVF VECTOR.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM
C        IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM.
C     INTEGER LACOV
C        THE LENGTH OF VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT
C        THIS ROUTINE WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(1)
C        A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCF(ISPCF,NW)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED
C        FOR EACH LAG WINDOW.
C     INTEGER WORK
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WINDOW.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS.
C     REAL Y(N)
C         THE ARRAY CONTAINING THE OBSERVED TIME SERIES.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS.
C     REAL YMISS
C        THE MISSING VALUE CODE FOR THE SERIES.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','S',' ',' '/
C
C     SET UP
C
      OPTION(4) = .TRUE.
      OPTION(3) = .FALSE.
      OPTION(2) = .FALSE.
      OPTION(1) = .FALSE.
C
C     SET MAXIMUM LAG VALUE TO BE USED.
C
      LAGMAX = N - 1
      IF (NW.LE.0) GO TO 20
      LAGMAX = LAGS(1)
      DO 10 I=1,NW
         LAGMAX = MAX(LAGMAX,LAGS(I))
   10 CONTINUE
   20 CONTINUE
      LACOV = LAGMAX + 1
      LNLPPA = 1
C
C     COMPUTE MINIMUM ALLOWABLE STACK LENGTH
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(5, 0, IO*(NF+5), 0, 0, 0, 'S',
     +   2*LAGMAX+2+IO*(2*NF+10), LDSMIN)
C
      LY = N
      LPCV = NF + 5
      LWORK = LAGMAX+1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C     SET THE STACK ALLOCATION TYPE.
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS.
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         ACOV = 1
         WORK = 1
         XAXIS = 1
         YAXIS = 1
         ISYM = 1
         ISORT = 1
      ELSE
         ACOV = STKGET(LACOV,IFP)
         WORK = STKGET(LWORK,IFP)
         IF (NPRT.NE.0) THEN
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
            ISYM = STKGET(LPCV,2)
            ISORT = ISYM
         ELSE
            XAXIS = WORK
            YAXIS = WORK
            ISYM = WORK
            ISORT = ISYM
         END IF
      END IF
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C
      CALL UFSDRV(Y, LY, YMISS, RSTAK(ACOV), NLPPA, SPCF, ISPCF,
     +   NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV,
     +   LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS),
     +   RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK,
     +   OPTION, LNLPPA, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFSS (Y, N,'/
     +   '      +           NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +   '      +           SPCF, ISPCF, FREQ, LDSTAK)')
      END
*UFSV
      SUBROUTINE UFSV(ACOV, LAGMAX, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS AND USER SUPPLIED ACVF VALUES (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
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
     +   LAGMAX,N
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,FMAX,FMIN,YMISS
      INTEGER
     +   IPRT,ISPCF,LACOV,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,LY,NF,
     +   NPRT,NW
C
C  LOCAL ARRAYS
      REAL
     +   FREQ(101),SPCF(101,4),WORK(101),XAXIS(106),Y(1),YAXIS(106)
      INTEGER
     +   ISORT(101),ISYM(106),LAGS(4),NLPPA(1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,PARZEN,UFSDRV
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LAGMAX+1)
C        THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE).
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE
C        SPECTRUM IS TO BE COMPUTED.
C     REAL FREQ(101)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
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 LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT(101)
C        AN ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISYM(106)
C        THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS.
C     INTEGER LACOV
C        THE LENGTH OF THE VECTOR ACOV.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(4)
C        THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(1)
C        A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL SPCF(101,4)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED.
C     REAL WORK(101)
C        THE VECTOR OF LAG WINDOWS.
C     REAL XAXIS(106)
C        THE X AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL Y(1)
C        A DUMMY ARRAY.
C     REAL YAXIS(106)
C        THE Y AXIS VALUES FOR THE SPECTRUM PLOT.
C     REAL YMISS
C        A DUMMY VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','V',' ',' '/
C
C     SET UP FOR ERROR CHECKING
C
      OPTION(4) = .FALSE.
      OPTION(3) = .TRUE.
      OPTION(2) = .FALSE.
      OPTION(1) = .FALSE.
C
      LDSTAK = 0
      LDSMIN = 0
C
      YMISS = 1.0E0
      LACOV = LAGMAX+1
C
      ISPCF = 101
      LY = 1
      LNLPPA = 1
      LPCV = 106
      LWORK = 101
      NF = 101
C
C     SET NUMBER OF LAG WINDOW TRUNCATION POINTS
C
      NW = 4
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C
      CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN,
     +   FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA,
     +   ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB,
     +   LDSMIN, LDSTAK, OPTION, LNLPPA, LY)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL UFSV (ACOV, LAGMAX, N)')
      END
*UFSVS
      SUBROUTINE UFSVS(ACOV, LAGMAX, N, NW, LAGS, NF,
     +   FMIN, FMAX, NPRT, SPCF, ISPCF, FREQ, LDSTAK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER
C     SPECTRUM ANALYSIS AND USER SUPPLIED ACVF VALUES (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 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   FMAX,FMIN
      INTEGER
     +   ISPCF,LAGMAX,LDSTAK,N,NF,NPRT,NW
C
C  ARRAY ARGUMENTS
      REAL
     +   ACOV(*),FREQ(*),SPCF(*)
      INTEGER
     +   LAGS(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      REAL
     +   ALPHA,DELTA,YMISS
      INTEGER
     +   IFP,IO,IPRT,ISORT,ISYM,LACOV,LDSMIN,LNLPPA,LPCV,LWORK,LY,
     +   NALL0,WORK,XAXIS,YAXIS
C
C  LOCAL ARRAYS
      REAL
     +   RSTAK(12),Y(1)
      INTEGER
     +   ISTAK(12),NLPPA(1)
      LOGICAL
     +   OPTION(4)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),RSTAK(1))
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL ACOV(LAGMAX+1)
C        THE AUTOCOVARIANCES OF THE SERIES.
C     REAL ALPHA
C        THE DESIRED CONFIDENCE LEVEL.
C     REAL DELTA
C        THE SAMPLING INTERVAL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     REAL FMAX, FMIN
C        THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM
C        IS TO BE COMPUTED.
C     REAL FREQ(NF)
C        THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE
C        COMPUTED.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF ERR01, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IO
C        A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED
C        BASED ON PRINTED OUTPUT REQUESTED.
C     INTEGER IPRT
C        THE LOGICAL UNIT USED FOR PRINTED OUTPUT.
C     INTEGER ISORT
C        THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING.
C     INTEGER ISPCF
C         THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISYM
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM.
C     INTEGER LACOV
C        THE LENGTH OF THE ACVF VECTORS.
C     INTEGER LAGMAX
C        THE MAXIMUM LAG VALUE TO BE USED.
C     INTEGER LAGS(NW)
C        THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION
C        POINTS USED FOR EACH SET OF SPECTRUM VALUES.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK.
C     INTEGER LNLPPA
C        THE LENGTH OF THE VECTOR NLPPA.
C     INTEGER LPCV
C        THE LENGTH OF THE VECTORS USED FOR PLOTTING.
C     INTEGER LWORK
C        THE LENGTH OF THE VECTOR W.
C     INTEGER LY
C        THE LENGTH OF THE VECTOR Y.
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES.
C     INTEGER NALL0
C        THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT
C        THIS ROUTINE WAS CALLED.
C     INTEGER NF
C        THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS
C        TO BE COMPUTED.
C     INTEGER NLPPA(1)
C        A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NPRT
C        A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF
C        NPRT < 0 THE PLOT IS DECIBLES/LINEAR
C        NPRT = 0 THE PLOT IS SUPPRESSED
C        NPRT > 0 THE PLOT IS LOG/LINEAR
C     INTEGER NW
C        THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT
C        BANDWIDTHS TO BE USED.
C     LOGICAL OPTION(4)
C        AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE
C        FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE)
C        OR NOT (FALSE).
C     EXTERNAL PARZEN
C        THE SUBROUTINE USED TO COMPUTE THE WINDOW.
C     REAL RSTAK(12)
C        THE REAL VERSION OF THE /CSTAK/ WORK AREA.
C     REAL SPCF(ISPCF,NW)
C        THE ARRAYS IN WHICH THE SPECTRUM IS STORED
C        FOR EACH LAG WINDOW.
C     INTEGER WORK
C        THE STARTING LOCATION IN RSTAK FOR
C        THE WORK VECTOR.
C     INTEGER XAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS.
C     REAL Y(1)
C        A DUMMY ARRAY.
C     INTEGER YAXIS
C        THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS.
C     REAL YMISS
C        A DUMMY VARIABLE.
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'U','F','S','V','S',' '/
C
C     SET UP
C
      OPTION(4) = .TRUE.
      OPTION(3) = .TRUE.
      OPTION(2) = .FALSE.
      OPTION(1) = .FALSE.
C
      LACOV = LAGMAX+1
C
C     COMPUTE MINIMUM ALLOWABLE STACK LENGTH
C
      IO = 1
      IF (NPRT.EQ.0) IO = 0
C
      CALL LDSCMP(4, 0, IO*(NF+5), 0, 0, 0, 'S',
     +   LAGMAX+1+IO*(2*NF+10), LDSMIN)
C
      YMISS = 1.0E0
C
      LY = 1
      LNLPPA = 1
      LPCV = NF + 5
      LWORK = LAGMAX+1
C
C     SET SIZE OF WORK AREA.
C     SET THE NUMBER OF OUTSTANDING ALLOCATIONS.
C     SET THE STACK ALLOCATION TYPE.
C
      CALL STKSET(LDSTAK, 4)
      NALL0 = STKST(1)
C
      IFP = 3
C
C     SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS.
C
      IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN
         WORK = 1
         XAXIS = 1
         YAXIS = 1
         ISYM = 1
         ISORT = 1
      ELSE
         WORK = STKGET(LWORK,IFP)
         IF (NPRT.NE.0) THEN
            XAXIS = STKGET(LPCV,IFP)
            YAXIS = STKGET(LPCV,IFP)
            ISYM = STKGET(LPCV,2)
            ISORT = ISYM
         ELSE
            XAXIS = WORK
            YAXIS = WORK
            ISYM = WORK
            ISORT = ISYM
         END IF
      END IF
C
C     CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES
C
      CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN,
     +   FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, LWORK,
     +   DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), RSTAK(YAXIS),
     +   LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK, OPTION,
     +   LNLPPA, LY)
C
      CALL STKCLR(NALL0)
C
C     CHECK FOR ERRORS
C
      IF (IERR.EQ.0) RETURN
C
      CALL IPRINT(IPRT)
      WRITE (IPRT,1000)
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL UFSVS (ACOV, LAGMAX, N,'/
     +   '      +            NW, LAGS, NF, FMIN, FMAX, NPRT,'/
     +   '      +            SPCF, ISPCF, FREQ, LDSTAK)')
      END
*V2NORM
      REAL 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
      REAL
     +   X(*)
C
C  LOCAL SCALARS
      REAL
     +   ONE,R,SCALE,SQTETA,T,XI,ZERO
      INTEGER
     +   I,J
C
C  EXTERNAL FUNCTIONS
      REAL
     +   RMDCON
      EXTERNAL RMDCON
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SQRT
C
C
      DATA ONE/1.0E0/, SQTETA/0.0E0/, ZERO/0.0E0/
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
*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
      REAL
     +   A
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      REAL
     +   W(*),X(*),Y(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C
      DO 10 I = 1, P
 10      W(I) = A*X(I) + Y(I)
      RETURN
      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
      REAL
     +   X(*),Y(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C
      DO 10 I = 1, P
 10      Y(I) = X(I)
      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
      REAL
     +   VCV(LVCV)
      INTEGER
     +   MASK(LMASK)
C
C  LOCAL SCALARS
      INTEGER
     +   CODE,I,II,IPRT,MODE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,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     REAL VCV(LVCV)
C        THE VARIANCE COVARIANCE MATRIX.
C
C     COMMENCE BODY OF ROUTINE
C
      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.0E0) GO TO 30
         IF (EST) GO TO 10
         WRITE (IPRT,1000)
         GO TO 20
C
   10    CONTINUE
         WRITE (IPRT,1050)
         IF (IVCVPT.EQ.1) WRITE (IPRT,1060)
         IF (IVCVPT.EQ.2) WRITE (IPRT,1070)
         IF (IVCVPT.EQ.3) WRITE (IPRT,1080)
   20    WRITE (IPRT,1010)
         GO TO 50
   30 CONTINUE
C
      IF (EST) GO TO 40
C
C     PRINT HEADING FOR CORRELATION ROUTINES
C
      WRITE (IPRT,1040)
      WRITE (IPRT,1030)
      MODE = 2
      GO TO 50
C
   40 CONTINUE
C
C     PRINT HEADING FOR ESTIMATION ROUTINES
C
      WRITE (IPRT,1050)
      IF (IVCVPT.EQ.1) WRITE (IPRT,1060)
      IF (IVCVPT.EQ.2) WRITE (IPRT,1070)
      IF (IVCVPT.EQ.3) WRITE (IPRT,1080)
      WRITE (IPRT,1020)
      MODE = 4
C
   50 CALL MATPRF(VCV, VCV, NPAR, MODE, CODE, LVCV, MASK, LMASK)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (///18H COVARIANCE MATRIX)
 1010 FORMAT (/39H     NONPOSITIVE VARIANCES ENCOUNTERED./10H     CORRE,
     +   39HLATION COEFFICIENTS CANNOT BE COMPUTED.)
 1020 FORMAT (4X, 36H- COVARIANCES ARE ABOVE THE DIAGONAL/4X, 7H- VARIA,
     +   24HNCES ARE ON THE DIAGONAL/4X, 27H- CORRELATION COEFFICIENTS ,
     +   22HARE BELOW THE DIAGONAL)
 1030 FORMAT (4X, 41H- STANDARD DEVIATIONS ARE ON THE DIAGONAL/4X,
     +   49H- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL)
 1040 FORMAT (/19H CORRELATION MATRIX)
 1050 FORMAT (///45H VARIANCE-COVARIANCE AND CORRELATION MATRICES,
     +   38H OF THE ESTIMATED (UNFIXED) PARAMETERS/ 1X, 82('-'))
 1060 FORMAT (/
     +   4X, 54H- APPROXIMATION BASED ON ASSUMPTION THAT RESIDUALS ARE,
     +   6H SMALL)
 1070 FORMAT (
     +   /4X, 51H- APPROXIMATION BASED ON ASYMPTOTIC MAXIMUM LIKELIH,
     +   10HOOD THEORY)
 1080 FORMAT (/4X,
     +   51H- APPROXIMATION BASED ON ASSUMPTION THAT CONDITIONS,
     +   10H NECESSARY/
     +   5X, 41H FOR ASYMPTOTIC MAXIMUM LIKELIHOOD THEORY,
     +   18H MIGHT BE VIOLATED)
      END
*VCVOUT
      SUBROUTINE VCVOUT(NP, VCV, IVCV, EST)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE VARIANCE COVARIANCE MATRIX.
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  -  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
     +   IVCV,NP
      LOGICAL
     +   EST
C
C  ARRAY ARGUMENTS
      REAL
     +   VCV(IVCV,NP)
C
C  LOCAL SCALARS
      REAL
     +   DEN,SVCVII,SVCVJJ
      INTEGER
     +   I,IPRT,J,K,MODE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,MATPRT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DEN
C        DENOMINATOR OF (I, J) CORRELATION COEFFICIENT
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 IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCV
C        THE EXACT FIRST DIMENSION OF THE MATRIX VCV.
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER MODE
C        IF MODE IS 1, PRINT FULL MATRIX.
C        IF MODE IS 2, PRINT LOWER TRIANGLE WITH SQUARE ROOTS OF
C                      OF THE DIAGONAL.
C     INTEGER NP
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     REAL SVCVII, SVCVJJ
C        SQUARE ROOTS OF VCV(I, I) AND VCV(J, J)
C     REAL VCV(IVCV,NP)
C        THE VARIANCE COVARIANCE MATRIX.
C
C     COMMENCE BODY OF ROUTINE
C
      CALL IPRINT(IPRT)
C
C     DETERMINE WHETHER TO ISSUE NEGATIVE VARIANCE WARNING
C
      MODE = 2
      DO 10 I=1,NP
         IF (VCV(I,I).GT.0.0E0) GO TO 10
         WRITE (IPRT,1000)
         IF (EST) WRITE (IPRT,1050)
         WRITE (IPRT,1010)
         MODE = 0
         GO TO 70
   10 CONTINUE
C
      IF (EST) GO TO 20
C
C     PRINT HEADING FOR CORRELATION ROUTINES
C
      WRITE (IPRT,1040)
      WRITE (IPRT,1030)
      MODE = 2
      GO TO 30
C
   20 CONTINUE
C
C     PRINT HEADING FOR ESTIMATION ROUTINES
C
      WRITE (IPRT,1050)
      WRITE (IPRT,1020)
      MODE = 1
C
   30 CONTINUE
C
C     COMPUTE THE CORRELATION COEFFICIENTS AND STORE IN THE BOTTOM HALF
C     OF THE VARIANCE COVARIANCE MATRIX
C
      IF (NP.EQ.1) GO TO 60
      DO 50 J=2,NP
         K = J - 1
         SVCVJJ = 0.0E0
         IF (VCV(J,J).GT.0.0E0) SVCVJJ = SQRT(VCV(J,J))
         DO 40 I=1,K
            SVCVII = 0.0E0
            IF (VCV(I,I).GT.0.0E0) SVCVII = SQRT(VCV(I,I))
            DEN = SVCVII*SVCVJJ
            IF (DEN.LE.0.0E0) VCV(J,I) = 0.0E0
            IF (DEN.GT.0.0E0) VCV(J,I) = VCV(J,I)/DEN
   40    CONTINUE
   50 CONTINUE
C
   60 CONTINUE
C
   70 CALL MATPRT(VCV, VCV, NP, IPRT, MODE, 1, IVCV)
C
C     RESTORE THE VCV MATRIX
C
      IF (NP.EQ.1) RETURN
      DO 90 J=2,NP
         K = J - 1
         DO 80 I=1,K
            VCV(J,I) = VCV(I,J)
   80    CONTINUE
   90 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/18H COVARIANCE MATRIX)
 1010 FORMAT (/39H     NONPOSITIVE VARIANCES ENCOUNTERED./10H     CORRE,
     +   39HLATION COEFFICIENTS CANNOT BE COMPUTED.)
 1020 FORMAT (4X, 36H- COVARIANCES ARE ABOVE THE DIAGONAL/4X, 7H- VARIA,
     +   24HNCES ARE ON THE DIAGONAL/4X, 27H- CORRELATION COEFFICIENTS ,
     +   22HARE BELOW THE DIAGONAL)
 1030 FORMAT (4X, 41H- STANDARD DEVIATIONS ARE ON THE DIAGONAL/4X,
     +   49H- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL)
 1040 FORMAT (/19H CORRELATION MATRIX)
 1050 FORMAT (/45H VARIANCE-COVARIANCE AND CORRELATION MATRICES,
     +   28H OF THE ESTIMATED PARAMETERS/ 1X, 72('-')/)
      END
*VERSP
      SUBROUTINE VERSP (WIDE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE VERSION NUMBER.
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
      INTEGER
     +   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT
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
      CALL IPRINT(IPRT)
C
      IF (WIDE) THEN
         WRITE(IPRT, 1000)
      ELSE
         WRITE(IPRT, 1010)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (105X, 'STARPAC 2.08S (03/15/90)')
 1010 FORMAT (54X, 'STARPAC 2.08S (03/15/90)')
      END
*VPC
      SUBROUTINE VPC(YM, N, NS, ILOG, ISIZE, IRLIN, IBAR,
     +   YLB, YUB, XLB, XINC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT (LONG CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IRLIN,ISIZE,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  ' ',       'V',       'P',       'C',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 0
      MISS = .FALSE.
      LISYM = 1
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL VPC (Y, N, NS, ILOG,'/
     +  '      +          ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)')
      END
      SUBROUTINE VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLING ROUTINE FOR USER CALLED VERTICAL PLOTS
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M,N,NS
      LOGICAL
     +   MISS,MULTI
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(*)
      INTEGER
     +   ISYM(*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   YMN,YMX
      INTEGER
     +   NSAMPL
      LOGICAL
     +   ERROR,XCHECK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL PLTCHK,VERSP,VPLMT,VPMN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MOD
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        A VALUE INDICATING WHETHER AN ERROR WAS DETECTEC (TRUE)
C        OR NOT (FALSE).
C     INTEGER IBAR
C        THE INDICATOR USED TO DESIGNATE WHETHER THE PLOT IS TO BE A
C        BAR GRAPH (IBAR.GE.1) OR NOT (IBAR.LE.0).
C     INTEGER IERR
C        THE COMMON VARIABLE USED TO INDICATE ERRORS,
C        IF =0, THEN NO ERRORS
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IRLIN
C        THE INDICATOR USED TO DESIGNATE WHETHER THE PLOT WILL HAVE
C        THE LOCATION OF ZERO PLOTTED AS A REFERENCE LINE (IRLIN.EQ.0),
C        THE LOCATION OF THE MEAN PLOTTED AS A REFERENCE LINE (IRLIN.GE.
C        OR NO REFERENCE LINE (IRLIN.LT.0).
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(LISYM)
C        VECTOR CONTAINING SYMBOLS FOR PLOTTING, NOT USED IN SOME CASES
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS, NSAMPL
C        THE SAMPLING FREQUENCY.
C     LOGICAL XCHECK
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER X-AXIS VALUES
C        ARE TO BE CHECKED (XCHECK = .TRUE.) OR NOT (XCHECK = .FALSE.)
C     REAL XINC
C        THE INCREMENT FOR THE X-AXIS.
C     REAL XLB
C        THE LOWER BOUND FOR THE X-AXIS.  (XLB=XUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YLB
C        THE LOWER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C     REAL YM(IYM,M)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(M)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YMN, YMX
C        THE Y-AYIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL YUB
C        THE UPPER BOUND FOR THE Y-AXIS.  (YLB=YUB INDICATES LIMITS ARE
C        TO BE DETERMINED FROM THE RANGE OF THE DATA.)
C
C
C     COMMENCE BODY OF ROUTINE
C
      XCHECK = .FALSE.
      CALL PLTCHK (YM, YMMISS, YM, YMMISS, N, M, IYM, MULTI,
     +   ILOG, YLB, YUB, XLB, XINC, NMSUB, MISS, XCHECK)

      IF (IERR.EQ.0) THEN
C
C       DETERMINE THE BOUNDS FOR THE AXIS AND COMPLETE ERROR CHECKING
C
        NSAMPL = MAX(1, NS)

        CALL VPLMT (YM, YMMISS, N, M, IYM, YLB, YUB, YMN, YMX,
     +    ERROR, NMSUB, MISS, NSAMPL)

        IF (ERROR) THEN
          IERR = 1
        ELSE
C
C       PRINT PLOT
C
        IF (MOD(MAX(0,ISIZE),10).EQ.0) THEN
          CALL VERSP(.TRUE.)
        ELSE
          CALL VERSP(.FALSE.)
        END IF

        CALL VPMN (YM, YMMISS, N, M, IYM, NSAMPL, ISCHCK, ISYM, LISYM,
     +    ISIZE, YMN, YMX, XLB, XINC, MISS, ILOG, IRLIN, IBAR)
C
        END IF
      END IF

      RETURN
      END
      SUBROUTINE VP(YM, N, NS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  ' ',       'V',       'P',       ' ',       ' ',       ' '/
C
C     DEFINE CONSTANTS
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 0
      ISIZE = -1
      MISS = .FALSE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL VP (Y, N, NS)')
      END
*VPHEAD
      SUBROUTINE VPHEAD(NSAMPL, IRLIN, IBAR,
     +                  REFPT, YWIDTH, YMN, YMX,
     +                  ISIZE, ILOG, LINE, NUMCOL, ILOGY, YDMN, YDMX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE HEADING FOR THE VERTICAL PLOT OUTPUT.
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
      REAL
     +   REFPT,YDMN,YDMX,YMN,YMX,YWIDTH
      INTEGER
     +   IBAR,ILOG,ILOGY,IRLIN,ISIZE,NSAMPL,NUMCOL
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   LINE(103)*1
C
C  LOCAL SCALARS
      REAL
     +   DELY
      INTEGER
     +   I,ICOL,IK,IPRT,JCOL,NLABLY,NLU
      CHARACTER
     +   FMT*4,YLFMT*205,YLFMT2*205
C
C  LOCAL ARRAYS
      REAL
     +   YLABEL(20)
      INTEGER
     +   ISPACE(20)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,LOGLMT,PRTCNT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG10,MAX,MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     REAL DELY
C        THE SCALE INTERVAL OF THE PLOT.
C     CHARACTER FMT*4
C        *
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER ICOL, IK
C        *
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER ILOGY
C        THE VALUE OF Q (SEE ILOG)
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISIZE
C     INTEGER ISPACE(20)
C     INTEGER JCOL
C     CHARACTER*1 LINE(103)
C     INTEGER NLABLY
C     INTEGER NLU
C     INTEGER NSAMPL
C        THE SAMPLING FREQUENCY,
C        WHERE IF NSAMPL .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     INTEGER NUMCOL
C        *
C     REAL REFPT
C        THE VALUE ZERO, OR THE MEAN OF THE SERIES, WHICH EVER IS
C        REQUESTED, USED AS A PLOT REFERENCE LINE.
C     REAL YDMN, YDMX
C        THE Y-AXIS DATA LIMITS ACTUALLY USED.
C     REAL YLABEL(20)
C        THE Y-AXIS LABLES.
C     CHARACTER YLFMT*205, YLFMT2*205
C        THE FORMATS USED TO PRINT THE X-AXIS
C     REAL YMN, YMX
C        THE GRAPH AXIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL YWIDTH
C        *
C
      CALL IPRINT(IPRT)
C
C     CHECK PLOT SEQUENCE.
C
      IF (NSAMPL.EQ.2) THEN
         WRITE(IPRT, 1003)
      ELSE IF (NSAMPL.EQ.3) THEN
         WRITE(IPRT, 1004)
      ELSE IF (NSAMPL.GE.4) THEN
         WRITE(IPRT, 1005) NSAMPL
      END IF
C
C     PRINT HEADINGS FOR Y
C
      IF (IBAR.EQ.0) THEN
         IF (IRLIN.GE.1) THEN
            WRITE(IPRT, 1006)
         ELSE IF (IRLIN.EQ.0) THEN
            WRITE(IPRT, 1007)
         END IF
      END IF
C
C     FIND SIZE OF PLOT TO BE CREATED
C
      IF (MOD(MAX(0,ISIZE),10).EQ.0) THEN
        NUMCOL=101
      ELSE
        NUMCOL = 51
      END IF
C
C     ADJUST FOR LOG PLOTS IF NECESSARY AND FIND AXIS LABELS
C
      CALL PRTCNT (MOD(MAX(0,ILOG),10),1,ILOGY)
      CALL LOGLMT (ILOGY, YMN, YMX, YLABEL, NUMCOL, 10, DELY, YWIDTH,
     +  NLABLY, YDMN, YDMX)
C
C     WRITE OUT THE HORIZONTAL AXIS AND THE AXIS LABELS.
C
      DO 330 ICOL=1,NUMCOL
         LINE(ICOL)='-'
  330 CONTINUE
      LINE(1)='I'
      IF (ILOGY.EQ.0) THEN
        NLU = NLABLY+1
        DO 340 ICOL=NUMCOL,1,-10
           LINE(ICOL)='I'
           NLU = NLU - 1
           ISPACE(NLU) = 1
  340   CONTINUE
      ELSE
        JCOL = 1
        LINE(JCOL) = 'I'
        NLU = NLABLY
        DO 345 IK = NLABLY,1,-1
          ICOL = ((LOG10(YLABEL(IK))-YMN)/YWIDTH)+1.5E0
          LINE(ICOL) = 'I'
          IF (ICOL-JCOL.GE.10) THEN
            ISPACE(NLU) = ICOL-JCOL-9
            NLU = NLU - 1
            YLABEL(NLU) = YLABEL(IK)
            JCOL = ICOL
          END IF
  345   CONTINUE
      END IF
      LINE(NUMCOL+1)='-'
      LINE(NUMCOL+2)=' '
C
C     CHECK X-AXIS LABELS FOR FORMAT
C
      FMT = 'F9.4'
      DO 350 I=1,NLABLY
         IF (((ABS(YLABEL(I)).GT.0.0E0).AND.
     +        (ABS(YLABEL(I)).LT.0.01E0)) .OR.
     +       ((YLABEL(I).GE.1.0E4).OR.(YLABEL(I).LE.(-1.0E3)))) THEN
           FMT = 'E9.3'
           GO TO 355
         END IF
  350 CONTINUE
  355 CONTINUE
      WRITE(YLFMT2,1000) NLABLY-NLU
      WRITE(YLFMT,YLFMT2) (FMT, ISPACE(I), I=NLABLY,NLU+1,-1), FMT
      WRITE(IPRT, YLFMT) (YLABEL(I),I=NLABLY,NLU,-1)
C
      WRITE(IPRT, 1001) '-', (LINE(ICOL), ICOL=1,NUMCOL+2)
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT ('(''(11X'',', I2, '('', '', A4, '','', I2, ''X''),',
     +  ''', '', A4, '')'')')
 1001 FORMAT (' ',13X, A1, 105A1)
 1003 FORMAT(45H0NOTE THAT EVERY OTHER POINT HAS BEEN PLOTTED)
 1004 FORMAT(45H0NOTE THAT EVERY THIRD POINT HAS BEEN PLOTTED)
 1005 FORMAT(17H0NOTE THAT EVERY , I2, 25HTH POINT HAS BEEN PLOTTED)
 1006 FORMAT(/' LOCATION OF MEAN IS GIVEN BY PLOT CHARACTER M')
 1007 FORMAT(/' LOCATION OF ZERO IS GIVEN BY PLOT CHARACTER 0')
      END
*VPL
      SUBROUTINE VPL(YM, N, NS, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT (LOG PLOT OPTION).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      REAL
     +   YMMISS(1)
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  ' ',       'V',       'P',       'L',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      YMMISS(1) = 1.0E0
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 0
      ISIZE = -1
      MISS = .FALSE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +   '       CALL VPL (Y, N, NS, ILOG)')
      END
      SUBROUTINE VPLMT (YM, YMMISS, N, M, IYM, YLB, YUB, YMN,
     +  YMX, ERROR, NMSUB, MISS, NSAMPL)
C
C     THIS ROUTINE SETS THE PLOT LIMITS FOR VERTICAL PLOTS
C
c  Discussion:
c
c    This routine had a minor logical flaw, in the case where all data was
c    missing.  In that case, the values of YMX and YMN were not set, but 
c    were then needed by the ADJLMT routine.  The correction was to initialize
c    the values.
c
c  Modified:
c
c    24 April 2006
c
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C

C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        A VALUE INDICATING WHETHER AN ERROR WAS DETECTED (TRUE)
C        OR NOT (FALSE).
C     LOGICAL HEAD
C        PRINT HEADING (HEAD=TRUE) OR NOT (HEAD=FALSE).
C     INTEGER I, II
C        INDEXING VARIABLES.
C     INTEGER IPRT
C        *
C     INTEGER IYM
C        ACTUAL ROW DIMENSION OF YM DECLARED IN THE USERS MAIN PROGRAM
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER M
C        THE NUMBER OF VECTORS IN YM
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS .
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NSAMPL
C        *
C     LOGICAL SETLMT
C        AN INDICATOR VARIABLE USED TO DETERMINE IF STARTING VALUES
C        FOR XLB, XINC, YMN, YMX HAVE BEEN FOUND.
C     REAL YLB
C        THE USER SUPPLIED Y-AXIS LOWER BOUND.
C     REAL YM(IYM,M)
C        THE ARRAY CONTAINING THE DEPENDENT VARIABLE(S).
C     REAL YMMISS(M)
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IS MISSING.
C        IF YM(I,J) = YMMISS(J), THE VALUE IS ASSUMED MISSING, OTHERWISE
C        IT IS NOT.
C     REAL YMN, YMX
C        THE Y-AXIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL YUB
C        THE USER SUPPLIED Y-AXIS UPPER BOUNDS.
C
      integer iym
      integer m

      logical error
      logical head
      integer i
      integer ii
      integer iprt
      integer j
      logical miss
      logical mvchk
      integer n
      character*1 nmsub(6)
      integer nsampl
      real r1mach
      logical setlmt
      real ylb
      real ym(iym,m)
      real ymmiss(m)
      real ymn
      real ymx
      real yub

      ERROR = .FALSE.
C
C       SET LIMITS TO USER SPECIFIED VALUES
C
      IF ( YLB.LT.YUB ) THEN

        YMN = YLB
        YMX = YUB
C
C       SET LIMITS TO RANGE OF VALUES WITHIN ANY USER SPECIFIED VALUES
C
      ELSE

        YMN =  r1mach ( 2 )
        YMX = -r1mach(2)

        SETLMT = .FALSE.
        II = 1
C
C       FIND FIRST VALUE TO BE PLOTTED
C
        DO 20 I=1,N,NSAMPL
           DO 10 J=1,M
              IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 10
              IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR.
     +           (YUB.LT.YM(I,J)))) GO TO 10
              IF (SETLMT) THEN
                YMN = MIN(YMN, YM(I,J))
                YMX = MAX(YMX, YM(I,J))
              ELSE
                YMN = YM(I,J)
                YMX = YM(I,J)
                SETLMT = .TRUE.
                II = I + NSAMPL
              END IF
   10      CONTINUE
           IF (SETLMT) GO TO 30
   20   CONTINUE
C
   30   IF (II.LE.1) THEN
C
C         NO VALUES TO BE PLOTTED.  PRINT ERROR MESSAGE
C
          ERROR = .TRUE.
          CALL IPRINT(IPRT)
          HEAD = .TRUE.
          CALL EHDR(NMSUB,HEAD)
          IF (YLB.GE.YUB) THEN
            WRITE (IPRT, 1010)
          ELSE
            WRITE (IPRT, 1020)
          END IF
          WRITE (IPRT, 1030)
C
        ELSE
C
C         FIND LIMITS FROM REMAINING VALUES
C
          IF (II.LE.N) THEN
            DO 50 I=II,N,NSAMPL
               DO 40 J=1,M
                  IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 40
                  IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR.
     +               (YUB.LT.YM(I,J)))) GO TO 40
                  YMN = MIN(YMN, YM(I,J))
                  YMX = MAX(YMX, YM(I,J))
   40          CONTINUE
   50       CONTINUE
          END IF
        END IF
C
C       ADJUST Y AXIS LIMITS IF EQUAL
C
        write ( *, * ) ' '
        write ( *, * ) 'VPLMT: DEBUG:'
        write ( *, * ) '  YMN = ', ymn
        write ( *, * ) '  YMX = ', ymx
        write ( *, * ) '  All is well?'
        IF (YMN .GE. YMX) then
          write ( *, * ) 'YMN .GE. YMX'
        end if

        IF (YMN .GE. YMX) then
          write ( *, * ) 'Gonna call'
          CALL ADJLMT ( YMN, YMX )
        end if

        write ( *, * ) '  VPLMT: DEBUG: Returned from ADJLMT'
      END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1010 FORMAT (/
     +   44H NO NON-MISSING PLOT COORDINATES WERE FOUND.)
 1020 FORMAT (/
     +   40H NO NON-MISSING VALUES WERE FOUND WITHIN,
     +   26H THE USER SUPPLIED LIMITS.)
 1030 FORMAT (/
     +   30H THE PLOT HAS BEEN SUPPRESSED.)
      END
*VPMC
      SUBROUTINE VPMC(YM, YMMISS, N, NS, ILOG, ISIZE,
     +   IRLIN, IBAR, YLB, YUB, XLB, XINC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA (LONG CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IRLIN,ISIZE,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(1)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   IPRT,ISCHCK,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  ' ',       'V',       'P',       'M',       'C',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ISCHCK = 0
      MISS = .TRUE.
      LISYM = 1
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL VPMC (Y, YMISS, N, NS, ILOG,'/
     +  '      +           ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)')
      END
*VPM
      SUBROUTINE VPM(YM, YMMISS, N, NS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA (SHORT CALL).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(1)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  ' ',       'V',       'P',       'M',       ' ',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      ILOG = -1
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 0
      ISIZE = -1
      MISS = .TRUE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL VPM (Y, YMISS, N, NS)')
      END
*VPML
      SUBROUTINE VPML(YM, YMMISS, N, NS, ILOG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL
C     PLOT WITH MISSING DATA (LOG PLOT OPTION).
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 21, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ILOG,N,NS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(*),YMMISS(1)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   XINC,XLB,YLB,YUB
      INTEGER
     +   IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M
      LOGICAL
     +   MISS,MULTI
C
C  LOCAL ARRAYS
      INTEGER
     +   ISYM(1)
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL IPRINT,VPCNT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     INTEGER IERR
C        A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER
C        OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS.
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER IPRT
C        OUTPUT LOGICAL UNIT NUMBER
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(1)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE FIRST DIMENSION OF ARRAY YM.
C     INTEGER LISYM
C        THE LENGTH OF ARRAY ISYM.
C     INTEGER M
C        NUMBER OF Y VECTORS
C     LOGICAL MISS
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES
C        MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.)
C     LOGICAL MULTI
C        INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES
C        ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.)
C     INTEGER N
C        LENGTH OF VECTORS
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     INTEGER NS
C        THE SAMPLING FREQUENCY,
C        WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED,
C                       = 2, EVERY OTHER POINT IS PLOTTED,
C                       = 3, EVERY THIRD POINT IS PLOTTED, ETC.
C     REAL XINC, XLB
C        INCREMENT AND LOWER BOUNDS FOR X-AXIS.
C     REAL YLB
C        LOWER BOUND FOR Y-AXIS.
C     REAL YM(N,1)
C        MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES
C     REAL YMMISS(1)
C        THE MISSING VALUE CODE FOR THE Y-AXIS.
C     REAL YUB
C        UPPER BOUND FOR Y-AXIS.
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     +    /  ' ',       'V',       'P',       'M',       'L',       ' '/
C
C     SET DEFAULT VALUES
C
      M = 1
      IYM = N
      MULTI = .FALSE.
      YLB = 0.0E0
      YUB = 0.0E0
      XLB = 1.0E0
      XINC = 1.0E0
      ISCHCK = 0
      ISIZE = -1
      MISS = .TRUE.
      LISYM = 1
      IRLIN = -1
      IBAR = 0
C
C     COMMENCE BODY OF ROUTINE
C
      CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB,
     +  XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE,
     +  MISS, LISYM)
C
      IF (IERR.NE.0) THEN
        IERR = 1
        CALL IPRINT(IPRT)
        WRITE (IPRT,1000)
      END IF
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS//
     +  '       CALL VPML (Y, YMISS, N, NS, ILOG)')
      END
*VPMN
      SUBROUTINE VPMN (YM, YMMISS, N, M, IYM, NSAMPL, ISCHCK, ISYM,
     +  LISYM, ISIZE, YMN, YMX, XLB, XINC, MISS, ILOG, IRLIN, IBAR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES VERTICAL PLOTS
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
      REAL
     +   XINC,XLB,YMN,YMX
      INTEGER
     +   IBAR,ILOG,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M,N,NSAMPL
      LOGICAL
     +   MISS
C
C  ARRAY ARGUMENTS
      REAL
     +   YM(IYM,M),YMMISS(M)
      INTEGER
     +   ISYM(LISYM)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      REAL
     +   REFPT,XLABEL,YDMN,YDMX,YWIDTH,YY
      INTEGER
     +   I,IEND,ILOGY,IMAX,IMIN,IPOINT,IPRT,IPTSYM,IREFPT,J,NUMCOL,
     +   NUSED
      LOGICAL
     +   IFMISS
      CHARACTER
     +   I0*1,IBLANK*1,IM*1,IPLTCH*1,IREFCH*1,FMT*72
C
C  LOCAL ARRAYS
      INTEGER
     +   ICOUNT(103)
      CHARACTER
     +   LINE(103)*1
C
C  EXTERNAL FUNCTIONS
      LOGICAL
     +   MVCHK
      EXTERNAL MVCHK
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEAN,AMEANM,IPRINT,PLINE,PLTPLX,PLTSYM,SETIV,VPHEAD
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG10,MAX,MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER FMT*72
C        THE FORMAT FOR THE X-AXIS LABELS
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IBAR
C        THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0)
C        OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED.
C     CHARACTER*1 IBLANK
C        THE PLOT SYMBOL BLANK.
C     INTEGER ICOUNT(103)
C        THE NUMBER OF PLOT SYMBOLS AT EACH LOCATION.
C     INTEGER IEND
C        THE NUMBER OF LOCATIONS IN THE PLOT STRING.
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     LOGICAL IFMISS
C        THE INDICATOR VARIABLE USED TO DETERMINE WHETHER THE
C        INPUT SERIES HAS MISSING DATA (TRUE) OR NOT (FALSE).
C     INTEGER ILOG
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG.
C     INTEGER ILOGY
C        THE VALUE OF Q (SEE ILOG).
C     CHARACTER*1 IM
C        THE PLOT SYMBOL M.
C     INTEGER IMAX
C        THE LARGEST LOCATION IN THE PLOT STRING BEING DEFINED.
C     INTEGER IMIN
C        THE SMALLEST LOCATION IN THE PLOT STRING BEING DEFINED.
C     CHARACTER*1 IPLTCH
C        THE PLOT CHARACTER USED FOR A GIVEN LINE OF THE PLOT.
C     INTEGER IPOINT
C        THE LOCATION IN THE PLOT STRING OF THE VALUE BEING PLOTTED.
C     INTEGER IPRT
C        *
C     INTEGER IPTSYM
C        AN INDICATOR VARIABLE USED TO DESIGNATE THE TYPE
C        OF PLOT.  IF ISCHCK = 1, THE PLOT IS A SYMPLE PAGE
C        OR VERTICAL PLOT.  IF ISCHCK = 2, THE PLOT IS A SYMBOL
C        PLOT.  IF ISCHCK = 3, THE PLOT IS A MULTIVARIATE PLOT.
C     CHARACTER*1 IREFCH
C        THE PLOT SYMBOL USED TO IDENTIFY THE PLOT REFERENCE LINE.
C     INTEGER IREFPT
C        THE LOCATION IN THE PLOT STRING FOR THE VALUE ZERO, OR
C        SERIES MEAN, WHICH EVER WAS REQUESTED.
C     INTEGER IRLIN
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE
C        SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER
C        NO REFERENCE LINE IS TO BE PLOTTED.
C        IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED.
C        IF IRLIN .EQ.  0, ZERO IS PLOTTED AS THE REFERENCE LINE.
C        IF IRLIN .GE.  1, THE SERIES MEAN IS PLOTTED.
C     INTEGER ISCHCK
C        THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS
C           WILL BE DESIGNATED, WHERE
C           0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN
C             THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED
C           1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE
C             N VECTOR ISYM
C           2 INDICATES THAT M SERIES ARE BEING PLOTTED.
C             SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM.
C     INTEGER ISIZE
C        THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE
C        P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS.
C        IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM.
C        IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU
C     INTEGER ISYM(LISYM)
C        VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING
C     INTEGER IYM
C        THE EXACT VALUE OF THE FIRST DIMENSION OF THE MATRIX YM.
C     CHARACTER*1 I0
C        THE PLOT SYMBOL -0-.
C     INTEGER J
C        AN INDEX VARIABLE.
C     CHARACTER*1 LINE(103)
C        THE VECTOR USED FOR THE PLOT STRING.
C     INTEGER LISYM
C        *
C     INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN YM.
C     LOGICAL MISS
C        *
C     INTEGER N
C        THE INTEGER NUMBER OF OBSERVATIONS .
C     INTEGER NSAMPL
C        THE SAMPLING FREQUENCY ACTUALLY USED.
C     INTEGER NUMCOL
C        *
C     INTEGER NUSED
C        THE NUMBER OF ACTIVE OBSERVATIONS.
C     REAL REFPT
C        THE VALUE ZERO, OR THE MEAN OF THE SERIES, WHICH EVER IS
C        REQUESTED, USED AS A PLOT REFERENCE LINE.
C     REAL XINC
C        THE VARIABLE USED TO SPECIFY THE INCREMENT FOR XLABEL.
C     REAL XLABEL
C        THE VALUE USED FOR THE LABELS ON THE RIGHT SIDE OF THE PLOT.
C     REAL XLB
C        THE STARTING VALUE FOR LABELS ON THE RIGHT SIDE OF THE GRAPH.
C     REAL YDMN, YDMX
C        THE Y-AXIS DATA LIMITS ACTUALLY USED.
C     REAL YM(IYM,M)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES
C     REAL YMMISS(M)
C        THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR
C        NOT AN OBSERVATION IN THE SERIES IS MISSING.  IF YM(I) = YMMISS
C        THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT.
C     REAL YMN, YMX
C        THE GRAPH AXIS LOWER AND UPPER LIMITS ACTUALLY USED.
C     REAL YWIDTH
C        THE SCALE INTERVAL OF THE PLOT.
C     REAL YY
C        THE VALUE OF YM ACTUALLY BEING PLOTTED
C
C
      DATA IBLANK/' '/, IM/'M'/, I0/'0'/
C
C     PRINT PLOT HEADINGS
C
      CALL IPRINT(IPRT)
      CALL VPHEAD(NSAMPL, IRLIN, IBAR,
     +            REFPT, YWIDTH, YMN, YMX, ISIZE, ILOG,
     +            LINE, NUMCOL, ILOGY, YDMN, YDMX)
      IEND = NUMCOL + 2
C
C     COMPUTE REFERENCE POINT OF GRAPH, IF REQUIRED.
C
      IF (IRLIN.GE.0) THEN
        IF (IRLIN.EQ.0) THEN
C
C         REFERENCE POINT IS ZERO
C
          REFPT = 0.0E0
          IREFCH = I0
        ELSE
C
C         REFERENCE POINT IS MEAN
C
          IF (MISS) THEN
            CALL AMEANM(YM, YMMISS, N, NUSED, REFPT)
          ELSE
            CALL AMEAN(YM, N, REFPT)
          END IF
          IF (ILOGY.NE.0) REFPT = LOG10(REFPT)
          IREFCH = IM
        END IF
C
C       COMPUTE LOCATION OF REFPT IN PLOT STRING
C
        CALL PLTPLX(REFPT, YMN, YWIDTH, IREFPT, IEND)
      ELSE
        IREFPT = 1
      END IF
C
C     BEGIN PLOTTING
C
      IPTSYM = ISCHCK + 1
      XLABEL = XLB
      DO 50 I=1,N,NSAMPL
         CALL PLINE(1, IEND, IBLANK, LINE)
         CALL SETIV(ICOUNT, IEND, 0)
         IFMISS = .FALSE.
         IPOINT = 1
         DO 30 J=1,M
           IF (MISS) THEN
             IFMISS = (IFMISS .OR. (MVCHK(YM(I,J),YMMISS(J))))
             IF (.NOT.(MVCHK(YM(I,J),YMMISS(J)))) THEN
               IF (ILOGY.EQ.0) THEN
                 YY = YM(I,J)
               ELSE
                 YY = LOG10(YM(I,J))
               END IF
               IF ((YY.GE.YDMN) .AND. (YY.LE.YDMX)) THEN
                CALL PLTPLX(YY, YMN, YWIDTH, IPOINT, IEND)
                CALL PLTSYM(IPTSYM, I, J, ISYM, N, IPOINT, LINE, ICOUNT)
                IPLTCH = LINE(IPOINT)
               ELSE
                IPOINT = IREFPT
                IPLTCH = IBLANK
               END IF
             END IF
           ELSE
             IF (ILOGY.EQ.0) THEN
               YY = YM(I,J)
             ELSE
               YY = LOG10(YM(I,J))
             END IF
             IF ((YY.GE.YDMN) .AND. (YY.LE. YDMX)) THEN
                CALL PLTPLX(YY, YMN, YWIDTH, IPOINT, IEND)
                CALL PLTSYM(IPTSYM, I, J, ISYM, N, IPOINT, LINE, ICOUNT)
                IPLTCH = LINE(IPOINT)
             ELSE
                IPOINT = IREFPT
                IPLTCH = IBLANK
             END IF
           END IF
   30    CONTINUE
         IF ((IBAR.GE.1) .AND. (.NOT.IFMISS)) THEN
            IMIN = MIN(IPOINT,IREFPT)
            IMAX = MAX(IPOINT,IREFPT)
            CALL PLINE(IMIN, IMAX, IPLTCH, LINE)
         ELSE IF (IRLIN.GE.0) THEN
            LINE(IREFPT) = IREFCH
         END IF
C
         IF (IFMISS) THEN
           WRITE(FMT,1000) NUMCOL, '8H MISSING'
           WRITE(IPRT,FMT) XLABEL, (LINE(J), J=1,IEND)
         ELSE
           WRITE(FMT,1000) NUMCOL, '1X, G11.5 '
           IF (M.EQ.1) THEN
             WRITE(IPRT,FMT) XLABEL, (LINE(J),J=1,IEND), YM(I,1)
           ELSE
             WRITE(IPRT,FMT) XLABEL, (LINE(J),J=1,IEND)
           END IF
         END IF
         XLABEL = XLABEL + XINC*NSAMPL
   50 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT('(1X,G11.5,1X,A1,''I'',', I3, 'A1,''I'',A1,',A10,')')
      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
      REAL
     +   S
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      REAL
     +   Y(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C
      DO 10 I = 1, P
 10      Y(I) = S
      RETURN
      END
*XERABT
      SUBROUTINE XERABT(MESSG,NMESSG)
C
C     LATEST REVISION  -  JANUARY 24, 1990 (JRD)
C
C     ABSTRACT
C        ***NOTE*** MACHINE DEPENDENT ROUTINE
C        XERABT ABORTS THE EXECUTION OF THE PROGRAM.
C        THE ERROR MESSAGE CAUSING THE ABORT IS GIVEN IN THE CALLING
C        SEQUENCE IN CASE ONE NEEDS IT FOR PRINTING ON A DAYFILE,
C        FOR EXAMPLE.
C
C     DESCRIPTION OF PARAMETERS
C        MESSG AND NMESSG ARE AS IN XERROR, EXCEPT THAT NMESSG MAY
C        BE ZERO, IN WHICH CASE NO MESSAGE IS BEING SUPPLIED.
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  7 JUNE 1978
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER NMESSG
C
C  ARRAY ARGUMENTS
      CHARACTER MESSG(1)*4
C
      STOP
      END
*XERCLR
      SUBROUTINE XERCLR
C
C     ABSTRACT
C        THIS ROUTINE SIMPLY RESETS THE CURRENT ERROR NUMBER TO ZERO.
C        THIS MAY BE NECESSARY TO DO IN ORDER TO DETERMINE THAT
C        A CERTAIN ERROR HAS OCCURRED AGAIN SINCE THE LAST TIME
C        NUMXER WAS REFERENCED.
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  7 JUNE 1978
C
C
C  VARIABLE DECLARATIONS
C
C  LOCAL SCALARS
      INTEGER JUNK
C
C  EXTERNAL FUNCTIONS
      INTEGER J4SAVE
      EXTERNAL J4SAVE
C
      JUNK = J4SAVE(1,0,.TRUE.)
      RETURN
      END
*XERCTL
      SUBROUTINE XERCTL(MESSG1,NMESSG,NERR,LEVEL,KONTRL)
C
C     ABSTRACT
C        ALLOWS USER CONTROL OVER HANDLING OF INDIVIDUAL ERRORS.
C        JUST AFTER EACH MESSAGE IS RECORDED, BUT BEFORE IT IS
C        PROCESSED ANY FURTHER (I.E., BEFORE IT IS PRINTED OR
C        A DECISION TO ABORT IS MADE) A CALL IS MADE TO XERCTL.
C        IF THE USER HAS PROVIDED HIS OWN VERSION OF XERCTL, HE
C        CAN THEN OVERRIDE THE VALUE OF KONTROL USED IN PROCESSING
C        THIS MESSAGE BY REDEFINING ITS VALUE.
C        KONTRL MAY BE SET TO ANY VALUE FROM -2 TO 2.
C        THE MEANINGS FOR KONTRL ARE THE SAME AS IN XSETF, EXCEPT
C        THAT THE VALUE OF KONTRL CHANGES ONLY FOR THIS MESSAGE.
C        IF KONTRL IS SET TO A VALUE OUTSIDE THE RANGE FROM -2 TO 2,
C        IT WILL BE MOVED BACK INTO THAT RANGE.
C
C     DESCRIPTION OF PARAMETERS
C
C      --INPUT--
C        MESSG1 - THE FIRST WORD (ONLY) OF THE ERROR MESSAGE.
C        NMESSG - SAME AS IN THE CALL TO XERROR OR XERRWV.
C        NERR   - SAME AS IN THE CALL TO XERROR OR XERRWV.
C        LEVEL  - SAME AS IN THE CALL TO XERROR OR XERRWV.
C        KONTRL - THE CURRENT VALUE OF THE CONTROL FLAG AS SET
C                 BY A CALL TO XSETF.
C
C      --OUTPUT--
C        KONTRL - THE NEW VALUE OF KONTRL.  IF KONTRL IS NOT
C                 DEFINED, IT WILL REMAIN AT ITS ORIGINAL VALUE.
C                 THIS CHANGED VALUE OF CONTROL AFFECTS ONLY
C                 THE CURRENT OCCURRENCE OF THE CURRENT MESSAGE.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER KONTRL,LEVEL,MESSG1,NERR,NMESSG
C
      RETURN
      END
*XERPRT
      SUBROUTINE XERPRT(MESSG,NMESSG)
C
C     ABSTRACT
C        PRINT THE HOLLERITH MESSAGE IN MESSG, OF LENGTH MESSG,
C        ON EACH FILE INDICATED BY XGETUA.
C        THIS VERSION PRINTS EXACTLY THE RIGHT NUMBER OF CHARACTERS,
C        NOT A NUMBER OF WORDS, AND THUS SHOULD WORK ON MACHINES
C        WHICH DO NOT BLANK FILL THE LAST WORD OF THE HOLLERITH.
C
C     RON JONES, JUNE 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER NMESSG
C
C  ARRAY ARGUMENTS
      CHARACTER MESSG(NMESSG)*4
C
C  LOCAL SCALARS
      INTEGER I,IUNIT,KUNIT,NCHAR,NCHARL,NCHLST,NCHREM,NFIELD,NLINES,
     +   NUNIT,NWORD,NWORD1,NWORD2
      CHARACTER LA*1,LBLANK*1,LCOM*1
C
C  LOCAL ARRAYS
      INTEGER LUN(5)
      CHARACTER F(10)*1,G(14)*1
C
C  EXTERNAL FUNCTIONS
      INTEGER I1MACH
      EXTERNAL I1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL S88FMT,XGETUA
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
      DATA F(1),F(2),F(3),F(4),F(5),F(6),F(7),F(8),F(9),F(10)
     1   / '(' ,'1' ,'X' ,',' ,' ' ,' ' ,'A' ,' ' ,' ' ,')' /
      DATA G(1),G(2),G(3),G(4),G(5),G(6),G(7),G(8),G(9),G(10)
     1   / '(' ,'1' ,'X' ,' ' ,' ' ,' ' ,' ' ,' ' ,' ' ,' ' /
      DATA G(11),G(12),G(13),G(14)
     1   / ' '  ,' '  ,' '  ,')'  /
      DATA LA/'A'/,LCOM/','/,LBLANK/' '/
C     PREPARE FORMAT FOR WHOLE LINES
      NCHAR = I1MACH(6)
      NFIELD = 72/NCHAR
      CALL S88FMT(2,NFIELD,F(5))
      CALL S88FMT(2,NCHAR,F(8))
C     PREPARE FORMAT FOR LAST, PARTIAL LINE, IF NEEDED
      NCHARL = NFIELD*NCHAR
      NLINES = NMESSG/NCHARL
      NWORD  = NLINES*NFIELD
      NCHREM = NMESSG - NLINES*NCHARL
      IF (NCHREM.LE.0) GO TO 40
         DO 10 I=4,13
10          G(I) = LBLANK
         NFIELD = NCHREM/NCHAR
         IF (NFIELD.LE.0) GO TO 20
C        PREPARE WHOLE WORD FIELDS
            G(4) = LCOM
            CALL S88FMT(2,NFIELD,G(5))
            G(7) = LA
            CALL S88FMT(2,NCHAR,G(8))
20       CONTINUE
         NCHLST = MOD(NCHREM,NCHAR)
         IF (NCHLST.LE.0) GO TO 30
C        PREPARE PARTIAL WORD FIELD
            G(10) = LCOM
            G(11) = LA
            CALL S88FMT(2,NCHLST,G(12))
30       CONTINUE
40    CONTINUE
C     PRINT THE MESSAGE
      NWORD1 = NWORD+1
      NWORD2 = (NMESSG+NCHAR-1)/NCHAR
      CALL XGETUA(LUN,NUNIT)
      DO 50 KUNIT = 1,NUNIT
         IUNIT = LUN(KUNIT)
         IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
         IF (NWORD.GT.0) WRITE (IUNIT,F) (MESSG(I),I=1,NWORD)
         IF (NCHREM.GT.0) WRITE (IUNIT,G) (MESSG(I),I=NWORD1,NWORD2)
50    CONTINUE
      RETURN
      END
*XERROR
      SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL)
C
C     ABSTRACT
C        XERROR PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER
C        DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE
C        OF THE LIBRARY ERROR CONTROL FLAG, KONTRL.
C        (SEE SUBROUTINE XSETF FOR DETAILS.)
C
C     DESCRIPTION OF PARAMETERS
C      --INPUT--
C        MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED, CONTAINING
C                NO MORE THAN 72 CHARACTERS.
C        NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG.
C        NERR  - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE.
C                NERR MUST NOT BE ZERO.
C        LEVEL - ERROR CATEGORY.
C                =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR.
C                =1 MEANS THIS IS A RECOVERABLE ERROR.  (I.E., IT IS
C                   NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.)
C                =0 MEANS THIS IS A WARNING MESSAGE ONLY.
C                =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE
C                   PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY
C                   TIMES THIS CALL IS EXECUTED.
C
C     EXAMPLES
C        CALL XERROR('SMOOTH -- NUM WAS ZERO.',23,1,2)
C        CALL XERROR('INTEG  -- LESS THAN FULL ACCURACY ACHIEVED.',
C                    43,2,1)
C        CALL XERROR(  'ROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL
C    1 FULLY COLLAPSED.',65,3,0)
C        CALL XERROR('EXP    -- UNDERFLOWS BEING SET TO ZERO.',39,1,-1)
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  7 FEB 1979
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER LEVEL,NERR,NMESSG
C
C  ARRAY ARGUMENTS
      CHARACTER MESSG(NMESSG)*4
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERRWV
C
      CALL XERRWV(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.)
      RETURN
      END
*XERRWV
      SUBROUTINE XERRWV(MESSG,NMESSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2)
C
C     ABSTRACT
C        XERRWV PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER
C        DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE
C        OF THE LIBRARY ERROR CONTROL FLAG, KONTRL.
C        (SEE SUBROUTINE XSETF FOR DETAILS.)
C        IN ADDITION, UP TO TWO INTEGER VALUES AND TWO REAL
C        VALUES MAY BE PRINTED ALONG WITH THE MESSAGE.
C
C     DESCRIPTION OF PARAMETERS
C      --INPUT--
C        MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED.
C        NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG.
C        NERR  - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE.
C                NERR MUST NOT BE ZERO.
C        LEVEL - ERROR CATEGORY.
C                =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR.
C                =1 MEANS THIS IS A RECOVERABLE ERROR.  (I.E., IT IS
C                   NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.)
C                =0 MEANS THIS IS A WARNING MESSAGE ONLY.
C                =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE
C                   PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY
C                   TIMES THIS CALL IS EXECUTED.
C        NI    - NUMBER OF INTEGER VALUES TO BE PRINTED. (O TO 2)
C        I1    - FIRST INTEGER VALUE.
C        I2    - SECOND INTEGER VALUE.
C        NR    - NUMBER OF REAL VALUES TO BE PRINTED. (0 TO 2)
C        R1    - FIRST REAL VALUE.
C        R2    - SECOND REAL VALUE.
C
C     EXAMPLES
C        CALL XERROR('SMOOTH -- NUM (=I1) WAS ZERO.',29,1,2,
C    1   1,NUM,0,0,0.,0.)
C        CALL XERRWV(  'QUADXY -- REQUESTED ERROR (R1) LESS THAN MINIMUM
C    1 (R2).',54,77,1,0,0,0,2,ERRREQ,ERRMIN)
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  19 MAR 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      REAL R1,R2
      INTEGER I1,I2,LEVEL,NERR,NI,NMESSG,NR
C
C  ARRAY ARGUMENTS
      CHARACTER MESSG(NMESSG)*4
C
C  LOCAL SCALARS
      INTEGER IFATAL,IUNIT,JUNK,KDUMMY,KOUNT,KUNIT,LERR,LKNTRL,LLEVEL,
     +   LMESSG,MAXMES,MKNTRL,NUNIT
      CHARACTER LFIRST*4
C
C  LOCAL ARRAYS
      INTEGER LUN(5)
C
C  EXTERNAL FUNCTIONS
      INTEGER I1MACH,J4SAVE
      EXTERNAL I1MACH,J4SAVE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FDUMP,XERABT,XERCTL,XERPRT,XERSAV,XGETUA
C
C  INTRINSIC FUNCTIONS
      INTRINSIC IABS,MAX,MIN
C
C     GET FLAGS
      LKNTRL = J4SAVE(2,0,.FALSE.)
      MAXMES = J4SAVE(4,0,.FALSE.)
C     CHECK FOR VALID INPUT
      IF ((NMESSG.GT.0).AND.(NERR.NE.0).AND.
     1    (LEVEL.GE.(-1)).AND.(LEVEL.LE.2)) GO TO 10
         IF (LKNTRL.GT.0) CALL XERPRT('FATAL ERROR IN...',17)
         CALL XERPRT('XERROR -- INVALID INPUT',23)
         IF (LKNTRL.GT.0) CALL FDUMP
         IF (LKNTRL.GT.0) CALL XERPRT('JOB ABORT DUE TO FATAL ERROR.',
     1   29)
         IF (LKNTRL.GT.0) CALL XERSAV(' ',0,0,0,KDUMMY)
         CALL XERABT('XERROR -- INVALID INPUT',23)
         RETURN
   10 CONTINUE
C     RECORD MESSAGE
      JUNK = J4SAVE(1,NERR,.TRUE.)
      CALL XERSAV(MESSG,NMESSG,NERR,LEVEL,KOUNT)
C     LET USER OVERRIDE
      LFIRST = MESSG(1)
      LMESSG = NMESSG
      LERR = NERR
      LLEVEL = LEVEL
      CALL XERCTL(LFIRST,LMESSG,LERR,LLEVEL,LKNTRL)
C     RESET TO ORIGINAL VALUES
      LMESSG = NMESSG
      LERR = NERR
      LLEVEL = LEVEL
      LKNTRL = MAX(-2,MIN(2,LKNTRL))
      MKNTRL = IABS(LKNTRL)
C     DECIDE WHETHER TO PRINT MESSAGE
      IF ((LLEVEL.LT.2).AND.(LKNTRL.EQ.0)) GO TO 100
      IF (((LLEVEL.EQ.(-1)).AND.(KOUNT.GT.MIN(1,MAXMES)))
     1.OR.((LLEVEL.EQ.0)   .AND.(KOUNT.GT.MAXMES))
     2.OR.((LLEVEL.EQ.1)   .AND.(KOUNT.GT.MAXMES).AND.(MKNTRL.EQ.1))
     3.OR.((LLEVEL.EQ.2)   .AND.(KOUNT.GT.MAX(1,MAXMES)))) GO TO 100
         IF (LKNTRL.LE.0) GO TO 20
            CALL XERPRT(' ',1)
C           INTRODUCTION
            IF (LLEVEL.EQ.(-1)) CALL XERPRT
     1('WARNING MESSAGE...THIS MESSAGE WILL ONLY BE PRINTED ONCE.',57)
            IF (LLEVEL.EQ.0) CALL XERPRT('WARNING IN...',13)
            IF (LLEVEL.EQ.1) CALL XERPRT
     1      ('RECOVERABLE ERROR IN...',23)
            IF (LLEVEL.EQ.2) CALL XERPRT('FATAL ERROR IN...',17)
   20    CONTINUE
C        MESSAGE
         CALL XERPRT(MESSG,LMESSG)
         CALL XGETUA(LUN,NUNIT)
         DO 50 KUNIT=1,NUNIT
            IUNIT = LUN(KUNIT)
            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
            IF (NI.GE.1) WRITE (IUNIT,22) I1
            IF (NI.GE.2) WRITE (IUNIT,23) I2
            IF (NR.GE.1) WRITE (IUNIT,24) R1
            IF (NR.GE.2) WRITE (IUNIT,25) R2
   22       FORMAT (11X,'IN ABOVE MESSAGE, I1=',I10)
   23       FORMAT (11X,'IN ABOVE MESSAGE, I2=',I10)
   24       FORMAT (11X,'IN ABOVE MESSAGE, R1=',E20.10)
   25       FORMAT (11X,'IN ABOVE MESSAGE, R2=',E20.10)
            IF (LKNTRL.LE.0) GO TO 40
C              ERROR NUMBER
               WRITE (IUNIT,30) LERR
   30          FORMAT (' ERROR NUMBER =',I10)
   40       CONTINUE
   50    CONTINUE
C        TRACE-BACK
         IF (LKNTRL.GT.0) CALL FDUMP
  100 CONTINUE
      IFATAL = 0
      IF ((LLEVEL.EQ.2).OR.((LLEVEL.EQ.1).AND.(MKNTRL.EQ.2)))
     1IFATAL = 1
C     QUIT HERE IF MESSAGE IS NOT FATAL
      IF (IFATAL.LE.0) RETURN
      IF ((LKNTRL.LE.0).OR.(KOUNT.GT.MAX(1,MAXMES))) GO TO 120
C        PRINT REASON FOR ABORT
         IF (LLEVEL.EQ.1) CALL XERPRT
     1   ('JOB ABORT DUE TO UNRECOVERED ERROR.',35)
         IF (LLEVEL.EQ.2) CALL XERPRT
     1   ('JOB ABORT DUE TO FATAL ERROR.',29)
C        PRINT ERROR SUMMARY
         CALL XERSAV(' ',-1,0,0,KDUMMY)
  120 CONTINUE
C     ABORT
      IF ((LLEVEL.EQ.2).AND.(KOUNT.GT.MAX(1,MAXMES))) LMESSG = 0
      CALL XERABT(MESSG,LMESSG)
      RETURN
      END
*XERSAV
      SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT)
C
C     ABSTRACT
C        RECORD THAT THIS ERROR OCCURRED.
C
C     DESCRIPTION OF PARAMETERS
C     --INPUT--
C       MESSG, NMESSG, NERR, LEVEL ARE AS IN XERROR,
C       EXCEPT THAT WHEN NMESSG=0 THE TABLES WILL BE
C       DUMPED AND CLEARED, AND WHEN NMESSG IS LESS THAN ZERO THE
C       TABLES WILL BE DUMPED AND NOT CLEARED.
C     --OUTPUT--
C       ICOUNT WILL BE THE NUMBER OF TIMES THIS MESSAGE HAS
C       BEEN SEEN, OR ZERO IF THE TABLE HAS OVERFLOWED AND
C       DOES NOT CONTAIN THIS MESSAGE SPECIFICALLY.
C       WHEN NMESSG=0, ICOUNT WILL NOT BE ALTERED.
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  19 MAR 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER ICOUNT,LEVEL,NERR,NMESSG
C
C  ARRAY ARGUMENTS
      CHARACTER MESSG(NMESSG)*4
C
C  LOCAL SCALARS
      INTEGER I,II,IUNIT,KOUNTX,KUNIT,NCHAR,NCOL,NUNIT
C
C  LOCAL ARRAYS
      INTEGER KOUNT(10),LEVTAB(10),LUN(5),NERTAB(10)
      CHARACTER F(17)*1,MESTAB(10)*4
C
C  EXTERNAL FUNCTIONS
      INTEGER I1MACH
      EXTERNAL I1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL S88FMT,XGETUA
C
C     NEXT THREE DATA STATEMENTS ARE NEEDED MERELY TO SATISFY
C     CERTAIN CONVENTIONS FOR COMPILERS WHICH DYNAMICALLY
C     ALLOCATE STORAGE.
      DATA MESTAB(1),MESTAB(2),MESTAB(3),MESTAB(4),MESTAB(5),
     1     MESTAB(6),MESTAB(7),MESTAB(8),MESTAB(9),MESTAB(10)
     2     /'0','0','0','0','0','0','0','0','0','0'/
      DATA NERTAB(1),NERTAB(2),NERTAB(3),NERTAB(4),NERTAB(5),
     1     NERTAB(6),NERTAB(7),NERTAB(8),NERTAB(9),NERTAB(10)
     2     /0,0,0,0,0,0,0,0,0,0/
      DATA LEVTAB(1),LEVTAB(2),LEVTAB(3),LEVTAB(4),LEVTAB(5),
     1     LEVTAB(6),LEVTAB(7),LEVTAB(8),LEVTAB(9),LEVTAB(10)
     2     /0,0,0,0,0,0,0,0,0,0/
C     NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK
C     ERROR TABLE INITIALLY
      DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5),
     1     KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10)
     2     /0,0,0,0,0,0,0,0,0,0/
      DATA KOUNTX/0/
C     NEXT DATA STATEMENT SETS UP OUTPUT FORMAT
      DATA F(1),F(2),F(3),F(4),F(5),F(6),F(7),F(8),F(9),F(10),
     1     F(11),F(12),F(13),F(14),F(15),F(16),F(17)
     2     /'(' ,'1' ,'X' ,',' ,'A' ,' ' ,' ' ,',' ,'I' ,' ' ,
     3      ' ' ,',' ,'2' ,'I' ,'1' ,'0' ,')' /
      IF (NMESSG.GT.0) GO TO 80
C     DUMP THE TABLE
         IF (KOUNT(1).EQ.0) RETURN
C        PREPARE FORMAT
         NCHAR = I1MACH(6)
         CALL S88FMT(2,NCHAR,F(6))
         NCOL = 20 - NCHAR
         CALL S88FMT(2,NCOL,F(10))
C        PRINT TO EACH UNIT
         CALL XGETUA(LUN,NUNIT)
         DO 60 KUNIT=1,NUNIT
            IUNIT = LUN(KUNIT)
            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
C           PRINT TABLE HEADER
            WRITE (IUNIT,10)
   10       FORMAT ('0          ERROR MESSAGE SUMMARY'/
     1              ' FIRST WORD      NERR     LEVEL     COUNT')
C           PRINT BODY OF TABLE
            DO 20 I=1,10
               IF (KOUNT(I).EQ.0) GO TO 30
               WRITE (IUNIT,F) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I)
   20       CONTINUE
   30       CONTINUE
C           PRINT NUMBER OF OTHER ERRORS
            IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX
   40       FORMAT (/' OTHER ERRORS NOT INDIVIDUALLY TABULATED=',I10)
            WRITE (IUNIT,50)
   50       FORMAT (1X)
   60    CONTINUE
         IF (NMESSG.LT.0) RETURN
C        CLEAR THE ERROR TABLES
         DO 70 I=1,10
   70       KOUNT(I) = 0
         KOUNTX = 0
         RETURN
   80 CONTINUE
C     PROCESS A MESSAGE...
C     SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
C     OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
      DO 90 I=1,10
         II = I
         IF (KOUNT(I).EQ.0) GO TO 110
         IF (MESSG(1).NE.MESTAB(I)) GO TO 90
         IF (NERR.NE.NERTAB(I)) GO TO 90
         IF (LEVEL.NE.LEVTAB(I)) GO TO 90
         GO TO 100
   90 CONTINUE
C     THREE POSSIBLE CASES...
C     TABLE IS FULL
         KOUNTX = KOUNTX+1
         ICOUNT = 1
         RETURN
C     MESSAGE FOUND IN TABLE
  100    KOUNT(II) = KOUNT(II) + 1
         ICOUNT = KOUNT(II)
         RETURN
C     EMPTY SLOT FOUND FOR NEW MESSAGE
  110    MESTAB(II) = MESSG(1)
         NERTAB(II) = NERR
         LEVTAB(II) = LEVEL
         KOUNT(II)  = 1
         ICOUNT = 1
         RETURN
      END
*XGETF
      SUBROUTINE XGETF(KONTRL)
C
C     ABSTRACT
C        XGETF RETURNS THE CURRENT VALUE OF THE ERROR CONTROL FLAG
C        IN KONTRL.  SEE SUBROUTINE XSETF FOR FLAG VALUE MEANINGS.
C        (KONTRL IS AN OUTPUT PARAMETER ONLY.)
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  7 JUNE 1978
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER KONTRL
C
C  EXTERNAL FUNCTIONS
      INTEGER J4SAVE
      EXTERNAL J4SAVE
C
      KONTRL = J4SAVE(2,0,.FALSE.)
      RETURN
      END
*XGETUA
      SUBROUTINE XGETUA(IUNIT,N)
C
C     ABSTRACT
C        XGETUA MAY BE CALLED TO DETERMINE THE UNIT NUMBER OR NUMBERS
C        TO WHICH ERROR MESSAGES ARE BEING SENT.
C        THESE UNIT NUMBERS MAY HAVE BEEN SET BY A CALL TO XSETUN,
C        OR A CALL TO XSETUA, OR MAY BE A DEFAULT VALUE.
C
C     DESCRIPTION OF PARAMETERS
C      --OUTPUT--
C        IUNIT - AN ARRAY OF ONE TO FIVE UNIT NUMBERS, DEPENDING
C                ON THE VALUE OF N.  A VALUE OF ZERO REFERS TO THE
C                DEFAULT UNIT, AS DEFINED BY THE I1MACH MACHINE
C                CONSTANT ROUTINE.  ONLY IUNIT(1),...,IUNIT(N) ARE
C                DEFINED BY XGETUA.  THE VALUES OF IUNIT(N+1),...,
C                IUNIT(5) ARE NOT DEFINED (FOR N.LT.5) OR ALTERED
C                IN ANY WAY BY XGETUA.
C        N     - THE NUMBER OF UNITS TO WHICH COPIES OF THE
C                ERROR MESSAGES ARE BEING SENT.  N WILL BE IN THE
C                RANGE FROM 1 TO 5.
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER N
C
C  ARRAY ARGUMENTS
      INTEGER IUNIT(5)
C
C  LOCAL SCALARS
      INTEGER I,INDEX
C
C  EXTERNAL FUNCTIONS
      INTEGER J4SAVE
      EXTERNAL J4SAVE
C
      N = J4SAVE(5,0,.FALSE.)
      DO 30 I=1,N
         INDEX = I+4
         IF (I.EQ.1) INDEX = 3
         IUNIT(I) = J4SAVE(INDEX,0,.FALSE.)
   30 CONTINUE
      RETURN
      END
*XSETF
      SUBROUTINE XSETF(KONTRL)
C
C     ABSTRACT
C        XSETF SETS THE ERROR CONTROL FLAG VALUE TO KONTRL.
C        (KONTRL IS AN INPUT PARAMETER ONLY.)
C        THE FOLLOWING TABLE SHOWS HOW EACH MESSAGE IS TREATED,
C        DEPENDING ON THE VALUES OF KONTRL AND LEVEL.  (SEE XERROR
C        FOR DESCRIPTION OF LEVEL.)
C
C        IF KONTRL IS ZERO OR NEGATIVE, NO INFORMATION OTHER THAN THE
C        MESSAGE ITSELF (INCLUDING NUMERIC VALUES, IF ANY) WILL BE
C        PRINTED.  IF KONTRL IS POSITIVE, INTRODUCTORY MESSAGES,
C        TRACE-BACKS, ETC., WILL BE PRINTED IN ADDITION TO THE MESSAGE.
C
C              IABS(KONTRL)
C        LEVEL        0              1              2
C        VALUE
C          2        FATAL          FATAL          FATAL
C
C          1     NOT PRINTED      PRINTED         FATAL
C
C          0     NOT PRINTED      PRINTED        PRINTED
C
C         -1     NOT PRINTED      PRINTED        PRINTED
C                                  ONLY           ONLY
C                                  ONCE           ONCE
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  23 MAY 1979
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER KONTRL
C
C  LOCAL SCALARS
      INTEGER JUNK
C
C  EXTERNAL FUNCTIONS
      INTEGER J4SAVE
      EXTERNAL J4SAVE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL XERRWV
C
      IF ((KONTRL.GE.(-2)).AND.(KONTRL.LE.2)) GO TO 10
         CALL XERRWV('XSETF  -- INVALID VALUE OF KONTRL (I1).',33,1,2,
     1   1,KONTRL,0,0,0.,0.)
         RETURN
   10 JUNK = J4SAVE(2,KONTRL,.TRUE.)
      RETURN
      END
