subroutine abscom ( n, v, w, abstol, nfail )

!*****************************************************************************80
!
!! ABSCOM counts the entries of | V(1:N) - W(1:N) | greater than ABSTOL.
!
!  Discussion:
!
!    This routine computes the number of times the absolute difference
!    between V(I) and W(I), I = 1, 2, ..., N, is greater than ABSTOL.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!    Input, integer N, the number of observations.
!
!    Input, real V(N), W(N), the values being compared.
!
!    Input, real ABSTOL, the absolute tolerance used in the comparison.
!
!    Output, integer NFAIL, the total number of failures.
!
  implicit none

  real abstol
  integer i
  integer n
  integer nfail
  real v(*)
  real w(*)

  nfail = 0

  do i = 1, n
    if ( abstol < abs ( v(i) - w(i) ) ) then
      nfail = nfail + 1
    end if
  end do

  return
end
subroutine accdig ( ax, x, ad, n )

!*****************************************************************************80
!
!! ACCDIG returns the number of accurate digits in an approximation to X.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!    Input, real AX(N), the approximation to the solution.
!
!    Input, real X(N), the solution.
!
!    Output, real AD(N), the number of accurate digits.
!
!    Input, integer N, the number of elements being compared.
!
!  Local Parameters:
!
!    Local, real ADMAX, the number of digits carried in a floating
!    point computation.
!
!    Local, real FPLRS, the floating point largest relative spacing.
!
  implicit none

  integer n

  real ad(n)
  real admax
  real ax(n)
  real diff
  real fplrs
  integer i
  real x(n)

  fplrs = epsilon ( fplrs )

  admax = -log10 ( fplrs )

  do i = 1, n

    diff = ax(i) - x(i)

    if ( diff == 0.0E+00 ) then

      ad(i) = admax

    else

      ad(i) = 0.0E+00

      if ( 0.0E+00 < abs ( x(i) ) ) then
        ad(i) = log10 ( abs ( x(i) ) )
      end if

      if ( 0.0E+00 < abs ( diff ) ) then
        ad(i) = -log10 ( abs ( diff ) ) + ad(i)
      end if

      ad(i) = min ( ad(i),  admax )
      ad(i) = max ( ad(i), -admax )

    end if

  end do

  return
end
subroutine acfd ( y, n, lagmax, nfac, nd, iod, ldstak )

!*****************************************************************************80
!
!! ACFD computes autocorrelations and partial autocorrelations.
!
!  Discussion:
!
!    This is the user callable routine for computing the autocorrelations
!    and partial autocorrelations of a time series with differencing.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer acov
!        the starting location in dstak for
!        the autocovariance vector.
!     integer aic
!        the starting location in dstak for
!        the array containing the akaikes criterion for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the variable used to designate whether or not the series
!        being analyzed was differenced or not.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ftest
!        the starting location in dstak for
!        the array containing the partial f ratio and probabilities
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!     integer ifp
!        the indicator variable used to designate whether the floating
!        point variables are single (ifp=3) or double (ifp=4) precision.
!     integer iod(nfac)
!        the order of each of the difference factors.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     integer nd(nfac)
!        the array containing the number of times the difference
!        factors are to be applied.
!     integer ndum(1)
!        a dummy dimensioned variable.
!     logical newpg
!        the variable used to designate whether or not the output
!        is to begin on a new page.
!     integer nfac
!        the number of difference factors.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer ntimes
!        the number of times the first difference factor has been
!        applied.
!     integer nyd, nyf
!        the number of observations after the difference filter is
!        applied.
!     real ospvar
!        the one step prediction variance for the order selected (iar).
!     integer phi
!        the starting location in dstak for
!        the array of autoregressive coefficients for the selected
!        order.
!     integer prho
!        the starting location in the work area for prho.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrho
!        the starting location in the work area for sdrho.
!     integer work
!        the starting location in the work area for work.
!     real y(n)
!        the vector containing the observed time series
!     integer yf
!        the starting location in dstak for
!        the vector containing the difference filtered series.
!     real ymean
!        the mean of the observed time series
!     real ysd
!        the standard deviation of the observed time series
!
  implicit none

  integer n
  integer nfac

  integer iod(nfac)
  real y(n)

  integer lagmax,ldstak
!
!  array arguments
  integer &
     nd(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     chia,chiap,ospvar,ymean,ysd
  integer &
     acov,aic,ftest,i,iar,ifp,lacov,ldsmin,lyfft,nall0, &
     nfft,ntimes,nyd,nyf,phi,prho,sdrho,work,yf
  logical &
     differ,isfft,newpg
!
!  local arrays
  real &
     rstak(12)
  integer &
     ndum(1)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acfer,acfmn,acfout,difser,ldscmp,scopy,stkclr, &
     stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'a',       'c',       'f',       'd',       ' ',       ' '/

  ierr = 0
  lacov = lagmax+1
  differ = .true.
  isfft = .false.
  lyfft = 0
  nfft = 0

  call ldscmp(7, 0, 0, 0, 0, 0, 's', 7*lagmax+2+n, ldsmin)

  call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, &
    differ, nfac, nd, iod, isfft, lyfft, nfft)

  if ( ierr /= 0 ) then
    ierr = 1
    return
  end if
!
!  set up the work area.
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3

  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

  if ( ierr /= 0 ) then
    ierr = 1
    return
  end if

  newpg = .false.
  ntimes = 0
!
!  check whether there is more than one difference factor.
!
  if (nfac <= 1) then
    call scopy(n, y, 1, rstak(yf), 1)
  else
!
!  create new data by applying difference factors beyond the first.
!
    call difser(y, n, nfac-1, nd(2), iod(2), rstak(yf), nyf)
  end if

  nyd = n
!
!  call routine for main autocorrelation computations.
!
  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)

  ysd = sqrt(rstak(acov) * real ( n ) / real(n-1))
!
!  call routine to print out autocorrelations
!
  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)

  newpg = .true.
!
!  compute correlation analysis for first difference factor
!  applied 1 to nd(1) times
!
  if ((nfac >= 1) .and. (nd(1) >= 1)) then

    do i = 1, nd(1)

      call difser(rstak(yf), nyd, nfac-1, nd(2), iod(2), &
        rstak(yf), nyf)
!
!  call routine for main autocorrelation computations.
!
      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)

      ysd = sqrt(rstak(acov) * real ( n ) / real (n-1))
!
!  call routine to print out autocorrelations
!
      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)

    end do

  end if

  call stkclr(nall0)

  return
end
subroutine acfdtl ( ndf, nd, iod, ntimes )

!*****************************************************************************80
!
!! ACFDTL prints titles for ACORRD.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     character*1 icom
!        the hollerith value -,- (comma)
!     integer iod(ndf)
!        the order of each of the difference factors.
!     character*1 iper
!        the hollerith value -.- (period)
!     character*1 ipunct
!        the hollerith value of either comma or period.
!     integer istop
!        one less than the number of difference factors.
!     integer nd(ndf)
!        the array containing the number of times the difference
!        factors are to be applied.
!     integer ndf
!        the number of difference factors.
!     integer ntimes
!        the number of times the differencing factor has been applied.
!
  implicit none

  integer &
     ndf,ntimes
!
!  array arguments
  integer &
     iod(ndf),nd(ndf)
!
!
  integer &
     i,istop
  character &
     icom*1,iper*1,ipunct*1

  data icom/','/, iper/'.'/

  if (ndf <= 1) then
    write ( *, 1002 )
  else
    istop = ndf - 1
    ipunct = iper
    if (ntimes  >=  1) ipunct = icom
    write ( *, 1000)
    if (ndf == 2)  write ( *, 1001) nd(2), iod(2), iper
    if (ndf  >=  3) write ( *, 1001) &
     (nd(i), iod(i), icom, i = 1, istop), nd(ndf), iod(ndf), ipunct
  end if

  if (ntimes == 0) then
    return
  end if

  if (ndf  >=  2) write ( *, 1003) ntimes, iod(1)
  if (ndf == 1) write ( *, 1004) ntimes, iod(1)
  return

 1000 format(//' 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, ' and, in addition, differenced by ', i3, &
     ' factors of order ', i3, '.'//)
 1004 format(4x, ' differenced by ', i3, ' factors of order ', &
     i3, '.'//)
end
subroutine acfer ( nmsub, n, lagmax, lacov, ldstak, ldsmin, &
  differ, nfac, nd, iod, isfft, lyfft, nfft )

!*****************************************************************************80
!
!! ACFER does error checking for the ACF routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical differ
!        the indicator variable used to designate whether the calling
!        routine is acfd (differ = true) or not (differ = false)
!     logical err(15)
!        values indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!     integer iod(nfac)
!        the order of each of the difference vactors
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 llacov(8), llagmx(8), llds(8), llgmx1(8), llyfft(8),
!    *  ln(8), lnfft(8), lnm1(8), lone(8), lthree(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in each series
!     integer nd(nfac)
!        the array containing the number of times the difference factors
!        are to be applied
!     integer nfac
!        the number of factors.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!
  implicit none

  integer &
     lacov,lagmax,ldsmin,ldstak,lyfft,n,nfac,nfft
  logical &
     differ,isfft
!
!  array arguments
  integer &
     iod(*),nd(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer ierr
!
!
  integer &
     i
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,eisii,erdf
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',' ',' ',' '/

  ierr = 0
  head = .true.
  err(1:15) = .false.

  call eisge(nmsub, ln, n, 3, 2, head, err(1), lthree)

  if ( err(1) ) then
    ierr = 1
    return
  end if

  call eisii(nmsub, llagmx, lagmax, 1, n-1, 1, head, err(2), lone, lnm1)

  if (differ) then
    call erdf(nmsub, nfac, nd, iod, n, head, err(3))
  end if

  if ( err(2) ) then
    ierr = 1
    return
  end if

  call eisge(nmsub, llacov, lacov, lagmax+1, 2, head, err(4), llgmx1)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(5), llds)

  if (isfft) then
    call eisge(nmsub, llyfft, lyfft, nfft, 2, head, err(6), lnfft)
  end if

  do i = 1, 15
    if ( err(i) ) then
      ierr = 1
      return
    end if
  end do

  return
end
subroutine acf ( y, n )

!*****************************************************************************80
!
!! ACF is the simple interface to the autocorrelations routines.
!
!  Discussion:
!
!     this is the user callable routine for computing the auto-
!     correlations and partial autocorrelations of a time series
!     (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(101)
!        the autocovariance function estimate vector.
!     real aic(101)
!        the array containing akiakes criteria for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the indicator variable used to designate whether the calling
!        routine is acfd (differ = true) or not (differ = false)
!     real ftest(2, 100)
!        the array in which the f ratio and probability are stored.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer iod(1)
!        the order of each of the difference factors.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the vector aic.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in each series
!     integer nd(1)
!        the number of times each difference factor is to be applied
!     integer ndum(1)
!        a dummy array.
!     integer nfac
!        the number of difference factors
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nprt
!        the variable controling the printed output.
!     real ospvar
!        the one step prediction variance for the selected order (iar).
!     real phi(100)
!        the array of autoregressive coefficients for the selected
!        order.
!     real prho(100)
!        the array containing the partial acf estimates.
!     real rho(100)
!        the array containing the acf estimates.
!     real sdrho(100)
!        the array containing the standard errors of the acf estimates.
!     real work(100)
!        a vector used in the computations of the partial
!        autocorrelation coefficients.
!     real y(n)
!        the vector containing the observed time series
!     real ymean, ysd
!        the mean and standard deviation of the observed time series
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     chia,chiap,ospvar,ymean,ysd
  integer &
     iar,lacov,lagmax,laic,ldsmin,ldstak,lyfft,nfac,nfft, &
     nprt
  logical &
     differ,isfft
!
!  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
!
!  external subroutines
  external acfer,acfmn,acfout,setlag
!
!  common blocks
  common /errchk/ierr
!
!  equivalences
  equivalence (acov(2),rho(1))
  equivalence (work(1),sdrho(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5), nmsub(6) &
   /     'a',       'c',       'f',       ' ',       ' ',      ' '/

  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

  call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, &
    differ, nfac, nd, iod, isfft, lyfft, nfft)

  if (ierr == 0) then
!
!  set number of acf to be computed
!
    call setlag (n, lagmax)
!
!  call routine for main autocorrelation computations.
!
    call acfmn (y, n, lagmax, rho, sdrho, ymean, prho, aic, ftest, &
       phi, iar, ospvar, acov, lacov, laic, chia, chiap, work, nprt)
!
    ysd = sqrt(acov(1) * real ( n ) / real (n-1))
!
!       call routine to print out autocorrelations
!
    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

  if ( ierr /= 0 ) then
    ierr = 1
  end if

  return
end
subroutine acff ( yfft, n, lyfft, ldstak )

!*****************************************************************************80
!
!! ACFF computes autocorrelations of a time series using an FFT.
!
!  Discussion:
!
!    This is the user callable routine for computing the auto-
!    correlations and partial autocorrelations of a time series
!    using an fft (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(101)
!        the autocovariance vector.
!     real aic(101)
!       the array containing akaikes criteria for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the indicator variable used to designate whether the calling
!        routine is acfd (differ = true) or not (differ = false)
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real ftest(2, 100)
!        the array in which the f ratio and probability are stored.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr  /=  0 errors were detected.
!     integer ifp
!        the indicator variable used to designate whether the floating
!        point variables are single (ifp=3) or double (ifp=4) precision.
!     integer iod(1)
!        the order of each of the difference factors.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value requested.
!     integer laic
!        the length of the vector aic.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     integer nd(1)
!        the number of times each difference factor is to be applied
!     integer ndum(1)
!        a dummy array.
!     integer nfac
!        the number of difference factors
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     real ospvar
!        the one step prediction variance for the selected order (iar).
!     real phi(100)
!        the array of autoregressive coefficients for the selected
!        order.
!     real prho(100)
!        the array containing the parital acf estimates.
!     real rho(100)
!        the array containing the acf estimates.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrho
!        the starting location in dstak for
!        the array containing the standard errors of the acf estimates.
!     integer work
!        the starting location in the work area for work.
!     real yfft(lyfft)
!        the vector containing the observed time series
!     real ymean
!        the mean of the observed time series
!     real ysd
!        the standard deviation of the observed time series
!
  implicit none

  integer &
     ldstak,lyfft,n
!
!  array arguments
  real &
     yfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     chia,chiap,ospvar,ymean,ysd
  integer &
     iar,ifp,lacov,lagmax,laic,ldsmin,nall0,nfac,nfft, &
     sdrho,work
  logical &
     differ,isfft
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acfer,acfmnf,acfout,fftlen,ldscmp,setlag,stkclr, &
     stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (acov(2),rho(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'a',       'c',       'f',       'f',       ' ',       ' '/

  ierr = 0
  lacov = 101
  laic = 101
  differ = .false.
  nfac = 1
  nd(1) = 0
  iod(1) = 0
  isfft = .true.
!
!  Set number of ACF to be computed and length of extended series.
!
  if ( 3 <= n ) then
     call setlag(n, lagmax)
     call fftlen(n+lagmax, 4, nfft)
  end if

  call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin)
!
!  Call error checking routines.
!
  call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, &
    differ, nfac, nd, iod, isfft, lyfft, nfft)
!
!  Check whether an error has been detected.
!
  if (ierr==0) then
!
!  Set up the work area.
!
    call stkset (ldstak, 4)
    nall0 = stkst(1)

    ifp = 3

    work = stkget(nfft, ifp)
    sdrho = work

    if (ierr==0) then
!
!  Call routine for main autocorrelation computations.
!
      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)

      ysd = sqrt (acov(1) * real ( n ) / real (n - 1))
!
!  Print autocorrelations.
!
      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

    call stkclr(nall0)
  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine acffs ( yfft, n, lyfft, ldstak, lagmax, lacov, acov, iar, phi, &
  nprt )

!*****************************************************************************80
!
!! ACFFS uses an FFT with ACVF estimates for autocorrelations of a time series.
!
!  Discussion:
!
!     this is the user callable routine for computing the auto-
!     correlations and partial autocorrelations of a time series
!     using a fft with the computed acvf estimates returned to the users
!     routine (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance vector.
!     integer aic
!        the starting location in dstak for
!        the array containing the akaikes criterion for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the indicator variable used to designate whether the calling
!        routine is acfd (differ = true) or not (differ = false)
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ftest
!        the starting location in dstak for
!        the array containing the partial f ratio and probabilities
!     integer i
!        an indexing variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!     integer ifp
!        the indicator variable used to designate whether the floating
!        point variables are single (ifp=3) or double (ifp=4) precision.
!     integer iod(1)
!        the order of each of the difference factors.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     integer nd(1)
!        the number of times each difference factor is to be applied
!     integer ndum(1)
!        a dummy dimensioned variable.
!     integer nfac
!        the number of difference factors
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is made.
!     real ospvar
!        the one step prediction variance for the order selected (iar).
!     real phi(lagmax)
!        the array of autoregressive coefficients for the selected
!        order.
!     integer prho
!        the starting location in the work area for prho.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrho
!        the starting location in the work area for sdrho.
!     integer work
!        the starting location in the work area for work.
!     real yfft(lyfft)
!        the vector containing the observed time series
!     real ymean
!        the mean of the observed time series
!     real ysd
!        the standard deviation of the observed time series
!
  implicit none

  integer &
     iar,lacov,lagmax,ldstak,lyfft,n,nprt
!
!  array arguments
  real &
     acov(*),phi(*),yfft(*)
 
  integer ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     chia,chiap,ospvar,ymean,ysd
  integer &
     aic,ftest,ifp,ldsmin,nall0,nfac,nfft,prho,sdrho, &
     work
  logical &
     differ,isfft
!
!  local arrays
  real &
     rstak(12)
  integer &
     iod(1),nd(1),ndum(1)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acfer,acfmnf,acfout,fftlen,ldscmp,stkclr,stkset
!
 
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'a',       'c',       'f',       'f',       's',       ' '/

  ierr = 0
  differ = .false.
  nfac = 1
  nd(1) = 0
  iod(1) = 0
  isfft = .true.
!
!  set length of extended series
!
  nfft = 0
  if ((n >= 3) .and. (lagmax >= 1)) call fftlen(n+lagmax, 4, nfft)

  call ldscmp(4, 0, 0, 0, 0, 0, 's', (4*lagmax+1) + nfft, ldsmin)

  call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, &
    differ, nfac, nd, iod, isfft, lyfft, nfft)
!
!  check whether an error has been detected
!
  if (ierr==0) then
!
!  set up the work area.
!
    call stkset(ldstak, 4)
    nall0 = stkst(1)

    ifp = 3

    work = stkget(nfft, ifp)
    prho = stkget(lagmax, ifp)
    aic = stkget(lagmax+1, ifp)
    ftest = stkget(2*lagmax, ifp)
    sdrho = work

    if (ierr==0) then
!
!  call routine for main autocorrelation computations.
!
      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)

      ysd = sqrt (acov(1) * real ( n ) / real (n - 1))
!
!  call routine to print out autocorrelations
!
      if ((nprt /= 0) .or. (acov(1)==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)

      if (nprt /= 0) then
        acov(2:lagmax+1) = acov(2:lagmax+1) * acov(1)
      end if

    end if

    call stkclr(nall0)
  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine acflst ( rho, sdrho, nlppa, lagmax, ifmiss, chia, ndfchi, chiap )

!*****************************************************************************80
!
!! ACFLST lists the autocorrelations and other information.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real chia, chiap
!        the variables in chich the chi square statistic and
!        probability for the autocorrelations are stored.
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an index variable.
!     logical ifmiss
!        the indicator variable used to determine
!        whether the input series has missing data or not.
!     integer imax, imin
!        the index values of the first and last observation
!        to be printed per line
!     integer lag
!        the lag value of the autocorrelation or partial
!        autocorrelation being printed.
!     integer lagmax
!        the number of autocorrelations or partial autocorrelations
!        to be printed.
!     integer ndfchi
!        the degrees of freedom for the chi squared statistic.
!     integer nlppa(lagmax)
!        the array in which the number of lagged product pairs used to
!        compute each autocorrelation is stored
!     integer nperl
!        the number of values to be printed per line.
!     real rho(lagmax)
!        the array in which the autocorrelations are stored.
!     real sdrho(lagmax)
!        the array in which the standard errors of the autocorrelations
!        are stored
!
  implicit none

  real &
     chia,chiap
  integer &
     lagmax,ndfchi
  logical &
     ifmiss
!
!  array arguments
  real &
     rho(*),sdrho(*)
  integer &
     nlppa(*)
!
!
  real &
     fplm
  integer &
     i,imax,imin,lag,nperl

  fplm = huge ( fplm )

  nperl = 12
  do i = 1, lagmax, nperl
     imin = i
     imax = min(i + nperl - 1, lagmax)
     write ( *, 1000) (lag, lag = imin, imax)
     write ( *, 1001) (rho(lag), lag = imin, imax)
     write ( *, 1002) (sdrho(lag), lag = imin, imax)
     if (ifmiss) write ( *, 1003) (nlppa(lag), lag = imin, imax)
  end do

  if (sdrho(lagmax) == fplm) write ( *, 1004) fplm

  write ( *, 1005) chia, ndfchi, chiap

  return

 1000 format(/' lag               ', 12(1x, i6))
 1001 format( ' acf               ', 12(2x, f5.2))
 1002 format( ' standard error    ', 12(2x, f5.2))
 1003 format( ' no. of obs. used  ', 12(1x, i6))
 1004 format(///5x, f5.2, ' indicates value could not be computed', &
     ' due to missing data.')
 1005 format(///' the chi square test statistic of'/ &
     ' the null hypothesis of white noise    =', g21.4/ &
     ' degrees of freedom                    =', i17/ &
     ' observed significance level           =', f17.4)
end
subroutine acfm ( y, ymiss, n )

!*****************************************************************************80
!
!! ACFM computes autocorrelations of a time series with missing data.
!
!  Discussion:
!
!    this is the user callable routine for computing the auto-
!    correlations and partial autocorrelations of a time series
!    with missing values (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(101)
!        the autocovariance vector.
!     real aic(101)
!        the array containing the akaikes criterion for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the indicator variable used to designate whether the calling
!        routine is acfd (differ = true) or not (differ = false)
!     real ftest(2, 100)
!        the array containing the partial f ratio and probabilities
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer iod(1)
!        the order of each of the difference factors.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer laglst
!        the last lag before missing data caused the acvf of the
!        series not to be computed.
!     integer lagmax
!        the maximum lag value requested.
!     integer laic
!        the length of the vector aic.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        a dummy variable.
!     integer n
!        the integer number of observations in each series
!     integer nd(1)
!        the number of times each difference factor is to be applied
!     integer ndum(1)
!        a dummy array.
!     integer nfac
!        the number of difference factors
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is made.
!     integer nfft
!        the number of observations in the extended series.
!     integer nlppa(101)
!        the array containing the number of lagged product pairs
!        used to compute each acvf estimate.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     real ospvar
!        the one step prediction variance for the order selected (iar).
!     real phi(100)
!        the array of autoregressive coefficients for the selected
!        order.
!     real prho(100)
!        the array containing the pacf estimates.
!     real rho(100)
!        the array containing the acf estimates.
!     real sdrho(100)
!        the array containing the standard errors of the acf.
!     real work(100)
!        the array containing work area for the pacf computations.
!     real y(n)
!        the vector containing the observed time series
!     real ymean
!        the mean of the observed time series
!     real ymiss
!        the user supplied code which is used to determine whether
!        or not an observation in the series is missing.
!        if y(i) == ymiss, the value is assumed missing.
!        if y(i)  /=  ymiss, the value is assumed not missing.
!     real ysd
!        the standard deviation of the observed time series
!
  implicit none

  real &
     ymiss
  integer &
     n
!
!  array arguments
  real &
     y(*)

  integer ierr
!
!
  real &
     chia,chiap,ospvar,ymean,ysd
  integer &
     iar,lacov,laglst,lagmax,laic,ldsmin,ldstak,lyfft, &
     nfac,nfft,nprt
  logical &
     differ,isfft
!
!  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
!
!  external subroutines
  external acfer,acfmnm,acfout,setlag
!
  common /errchk/ierr
!
!  equivalences
  equivalence (acov(2),rho(1))
  equivalence (work(1),sdrho(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'a',       'c',       'f',       'm',       ' ',       ' '/

  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
!
!  call error checking routines
!
  call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, &
    differ, nfac, nd, iod, isfft, lyfft, nfft)
!
!  check whether an error has been detected
!
  if (ierr==0) then
!
!  set largest lag to be used.
!
    call setlag(n, lagmax)
!
!  call routine for main autocorrelation computations.
!
    call acfmnm (y, ymiss, n, lagmax, rho, sdrho, nlppa, ymean, &
       prho, aic, ftest, phi, iar, ospvar, acov, lacov, laic, chia, &
       chiap, laglst, work, nprt)

    ysd = acov(1)
    if (laglst >= 0) ysd = sqrt (acov(1) * real ( n ) / real (n - 1))
!
!  call routine to print out autocorrelations
!
    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

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine acfmn ( y, n, lagmax, rho, sdrho, ymean, prho, aic, &
  ftest, phi, iar, ospvar, acov, lacov, laic, chia, chiap, work, nprt )

!*****************************************************************************80
!
!! ACFMN computes autocorrelations of a time series.
!
!  Discussion:
!
!    This is the main subroutine for computing autocorrelations and
!    partial autocorrelations of a time series .
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance function estimate vector.
!     real aic(laic)
!        the array containing akaiaes criterion for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     real ftest(2, lagmax)
!        the array in which the f ratio and probability are stored.
!     integer i
!        an indexing variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the vector aic.
!     integer n
!        the integer number of observations in the series
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is made.
!     real ospvar
!        the one step prediction variance for the selected order (iar).
!     real phi(lagmax)
!        the array of autoregressive coefficients for the selected
!        order (iar).
!     real prho(lagmax)
!        the array in which the partial autocorrelations are stored
!     real rho(lagmax)
!        the array in which the autocorrelations are stored
!     real sdrho(lagmax)
!        the array in which the standard errors of the autocorrelations
!     real work(lagmax)
!        an array used in the computations of the partial
!        autocorrelations coefficients.
!        are stored
!     real y(n)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series.
!
  implicit none

  real &
     chia,chiap,ospvar,ymean
  integer &
     iar,lacov,lagmax,laic,n,nprt
!
!  array arguments
  real &
     acov(*),aic(*),ftest(2,*),phi(*),prho(*),rho(*),sdrho(*), &
     work(*),y(*)
!
!  external subroutines
  external acfsd,acvf,aos,chirho
!
!  compute autocovariancess and standard deviation of the series.
!
  call acvf(y, n, ymean, acov, lagmax, lacov)
!
  if (acov(1) == 0.0e0) return
!
!  compute partial autocorrelations and the autoregressive model
!  order selection statistics.
!
  call aos (n, lagmax, acov, prho, iar, ospvar, phi, work, &
     aic, ftest, lacov, laic)

  if (nprt == 0) return
!
!  Compute autocorrelations.
!
  rho(1:lagmax) = acov(2:lagmax+1) / acov(1)
!
!  Compute standard error of autocorrelations.
!
  call acfsd (rho, sdrho, lagmax, n)
!
!  compute chi statistic based on autocorrelation values
!
  call chirho (rho, n, lagmax, chia, chiap)

  return
end
subroutine acfmnf ( yfft, n, nfft, lagmax, rho, sdrho, ymean, &
  prho, aic, ftest, phi, iar, ospvar, acov, lacov, laic, &
  chia, chiap, lyfft, work, lwork, nprt )

!*****************************************************************************80
!
!! ACFMNF computes autocorrelations of a time series.
!
!  Discussion:
!
!    This is the main subroutine for computing autocorrelations and
!    partial autocorrelations of a time series .
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance function estimate vector.
!     real aic(laic)
!        the akaikes information criterion vector.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     real ftest(2, lagmax)
!        the array in which the partial f ratios and probabilities
!        are stored.
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the vector aic.
!     integer lwork
!        the length of the vector work.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in the series
!     integer nfft
!        the number of observations in the extended series.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is made.
!     real ospvar
!        the one step prediction variance.
!     real phi(lagmax)
!        the array of autoregressive coefficients for the selected
!        order (iar).
!     real prho(lagmax)
!        the array in which the partial autocorrelations are stored
!     real rho(lagmax)
!        the array in which the autocorrelations are stored
!     real sdrho(lagmax)
!        the array in which the standard errors of the autocorrelations
!        are stored
!     real work(lwork)
!        a work array.
!     real yfft(lyfft)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series
!
  implicit none

  real &
     chia,chiap,ospvar,ymean
  integer &
     iar,lacov,lagmax,laic,lwork,lyfft,n,nfft,nprt
!
!  array arguments
  real &
     acov(*),aic(*),ftest(2,*),phi(*),prho(*),rho(*),sdrho(*), &
     work(*),yfft(*)
!
!  external subroutines
  external acfsd,acvff,aos,chirho
!
!  compute autocovariancess and standard deviation of the series.
!
  call acvff(yfft, n, nfft, ymean, acov, lagmax, lacov, lyfft, work, &
     lwork)

  if (acov(1) == 0.0e0) return
!
!  compute partial autocorrelations and autoregressive order
!  selection statistics.
!
  call aos (n, lagmax, acov, prho, iar, ospvar, phi, work, &
     aic, ftest, lacov, laic)

  if (nprt == 0) return
!
!  Compute autocorrelations.
!
  rho(1:lagmax) = acov(2:lagmax+1) / acov(1)
!
!  Compute standard error of autocorrelations.
!
  call acfsd (rho, sdrho, lagmax, n)
!
!  compute chi statistic based on autocorrelation values
!
  call chirho (rho, n, lagmax, chia, chiap)

  return
end
subroutine acfmnm ( y, ymiss, n, lagmax, rho, sdrho, nlppa, ymean, &
  prho, aic, ftest, phi, iar, ospvar, acov, lacov, laic, chia, &
  chiap, laglst, work, nprt )

!*****************************************************************************80
!
!! ACFMNM computes autocorrelations of a time series with missing data.
!
!  Discussion:
!
!    This is the main subroutine for computing autocorrelations and
!    partial autocorrelations of a time series with missing data.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance function estimate vector.
!     real aic(laic)
!        the array containing akaiaes criterion for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     real fplm
!        the floating point largest magnitude.
!     real ftest(2, lagmax)
!        the array in which the f ratio and probability are stored.
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer lacov
!        the length of the vector acov.
!     integer laglst
!        the last lag before missing data caused the acvf of the
!        series not to be computed.
!     integer lagmax
!        the maximum lag value to be used.
!     integer n
!        the integer number of observations in the series
!     integer laic
!        the length of the vector aic.
!     integer nlppa(lacov)
!        the array containing the numbers of lagged product pairs
!        used to compute the acvf at each lag.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is made.
!     integer nused
!        the number of active (not missing) observations in the series.
!     real ospvar
!        the one step prediction variance for the selected order (iar).
!     real phi(lagmax)
!        the array of autoregressive coefficients for the selected
!        order (iar).
!     real prho(lagmax)
!        the array in which the partial autocorrelations are stored
!     real rho(lagmax)
!        the array in which the autocorrelations are stored
!     real sdrho(lagmax)
!        the array in which the standard errors of the autocorrelations
!        are stored
!     real work(lagmax)
!        an array used in the computations of the partial
!        autocorrelations coefficients.
!     real y(n)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series
!     real ymiss
!        the user supplied code which is used to determine whether
!        or not an observation in the series is missing.
!        if y(i) == ymiss, the value is assumed missing.
!        if y(i)  /=  ymiss, the value is assumed not missing.
!
  implicit none

  real &
     chia,chiap,ospvar,ymean,ymiss
  integer &
     iar,lacov,laglst,lagmax,laic,n,nprt
!
!  array arguments
  real &
     acov(*),aic(*),ftest(2,*),phi(*),prho(*),rho(*),sdrho(*), &
     work(*),y(*)
  integer &
     nlppa(*)
!
!
  real &
     fplm
  integer &
     i,nused
!
!  external subroutines
  external acfsdm,acvfm,aos,chirho

  fplm = huge ( fplm )
!
!  compute autocovariances of the series with missing data.
!
  call acvfm(y, ymiss, n, ymean, acov, lagmax, laglst, nlppa, lacov)

  if (nlppa(1) == 0 .or. acov(1) == 0.0e0) return

  if (nprt == 0) return
!
!  compute partial autocorrelations and the autoregressive model
!  order selection statistics if there were no missing data.
!
  if (nlppa(1) == n) then
    call aos (n, lagmax, acov, prho, iar, &
      ospvar, phi, work, aic, ftest, lacov, laic)
  end if
!
!  Compute autocorrelations.
!
  do i = 1, lagmax
    if ( 1 <= nlppa(i+1) ) then
      rho(i) = acov(i+1) / acov(1)
    end if
  end do
!
!  Preset sdrho values for printing routine.
!
  sdrho(laglst:lagmax) = fplm
!
!  Compute standard error of autocorrelations.
!
  call acfsdm (rho, sdrho, laglst, n, nlppa(2))

  if (laglst == 0) return
!
!  Compute chi statistic based on autocorrelation values.
!
  nused = nlppa(1)

  call chirho (rho, nused, laglst, chia, chiap)

  return
end
subroutine acfms ( y, ymiss, n, lagmax, lacov, acov, amiss, nlppa, &
  nprt, ldstak )

!*****************************************************************************80
!
!! ACFMS: user interface for autocorrelations of time series with missing data.
!
!  Discussion:
!
!    This is the user callable routine for computing the auto-
!    correlations of a time series with missing values (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance vector.
!     integer aic
!        the starting location in dstak for
!        the array containing the akaikes criterion for each order.
!     real amiss
!        the missing value code for the returned acvf estimates
!        (vector acov).
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the indicator variable used to designate whether the calling
!        routine is acfd (differ = true) or not (differ = false)
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fplm
!        the floating point largest magnitude.
!     integer ftest
!        the starting location in dstak for
!        the array containing the partial f ratio and probabilities
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!     integer ifp
!        the indicator variable used to designate whether the floating
!        point variables are single (ifp=3) or double (ifp=4) precision.
!     integer iod(1)
!        the order of each of the difference factors.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer laglst
!        the last lag before missing data caused the acvf of the
!        series not to be computed.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     integer nd(1)
!        the number of times each difference factor is to be applied
!     integer ndum(1)
!        a dummy array.
!     integer nfac
!        the number of difference factors
!     integer nfft
!        the number of observations in the extended series.
!     integer nlppa(lacov)
!        the array containing the number of lagged product pairs
!        used to compute each acvf estimate.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is made.
!     real ospvar
!        the one step prediction variance for the order selected (iar).
!     integer phi
!        the starting location in dstak for the
!        the array of autoregressive coefficients for the selected
!        order.
!     integer prho
!        the starting location in the work area for prho.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrho
!        the starting location in the work area for sdrho.
!     integer work
!        the starting location in the work area for work.
!     real y(n)
!        the vector containing the observed time series
!     real ymean
!        the mean of the observed time series
!     real ymiss
!        the user supplied code which is used to determine whether
!        or not an observation in the series is missing.
!        if y(i) == ymiss, the value is assumed missing.
!        if y(i)  /=  ymiss, the value is assumed not missing.
!     real ysd
!        the standard deviation of the observed time series
!
  implicit none

  real &
     amiss,ymiss
  integer &
     lacov,lagmax,ldstak,n,nprt
!
!  array arguments
  real &
     acov(*),y(*)
  integer &
     nlppa(*)
!
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     chia,chiap,fplm,ospvar,ymean,ysd
  integer &
     aic,ftest,iar,ifp,laglst,ldsmin,lyfft,nall0,nfac, &
     nfft,phi,prho,sdrho,work
  logical &
     differ,isfft
!
!  local arrays
  real &
     rstak(12)
  integer &
     iod(1),nd(1),ndum(1)
  character &
     nmsub(6)*1
!
!  external functions

  integer &
     stkget,stkst
  external stkget,stkst
!
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'a',       'c',       'f',       'm',       's',       ' '/

  ierr = 0
  differ = .false.
  nfac = 1
  nd(1) = 0
  iod(1) = 0
  isfft = .false.
  lyfft = n
  nfft = n

  if (nprt == 0) then
    ldsmin = 0
  else
    call ldscmp(5, 0, 0, 0, 0, 0, 's', 6*lagmax+1, ldsmin)
  end if

  call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, &
    differ, nfac, nd, iod, isfft, lyfft, nfft)
!
!  check whether an error has been detected
!
  if (ierr==0) then
!
!  set up the work area.
!
    call stkset(ldstak, 4)
    nall0 = stkst(1)

    fplm = huge ( fplm )

    amiss = fplm

    if (nprt==0) then
!
!  specify starting locations in the stack for dummy variables
!
      prho = 1
      aic = 1
      ftest = 1
      phi = 1
      work = 1
      sdrho = 1
    else

      ifp = 3

      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

    if (ierr==0) then
!
!  Main autocorrelation computations.
!
      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)

      if (laglst  >=  0) then
        ysd = sqrt (acov(1) * real ( n ) / real (n - 1) )
      else
        ysd = acov(1)
      end if
!
!  Print out autocorrelations
!
      if ((nprt /= 0) .or. (acov(1)==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)

      if (nprt /= 0) then
        acov(2:lagmax+1) = acov(2:lagmax+1) * acov(1)
      end if

    end if

    call stkclr(nall0)
  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
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 )

!*****************************************************************************80
!
!! ACFOUT prints autocorrelations.
!
!  Discussion:
!
!    This routine prints the autocorrelations and their
!    standard errors, as well and the partial autocorrelations
!    and miscellaneous summary information.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real aic(laic)
!        the array containing the akaikes information criterion.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the variable used to designate whether or not the series
!        analyzed was differenced or not.
!     real fplm
!        the floating point largest magnitude.
!     real ftest(2, lagmax)
!        the array in which the f ratio and probability are stored.
!     integer iar
!        the order of the autoregressive process chosen.
!     logical ifmiss
!        the indicator variable used to determine
!        whether the input series has missing data or not.
!     integer iod(nfac)
!        the order of each of the differencing factors.
!     integer isym(1)
!        a dummy array.
!     integer lagmax
!        the maximum lag value used.
!     integer laic
!        the length of the vector aic.
!     integer n
!        the integer number of observations in each series
!     integer nd(nfac)
!        the array contaning the number of times the differencing
!        factors are to be applied.
!     integer ndfchi
!        the degrees of freedom for the chi squared statistic.
!     logical newpg
!        the variable designating whether or not the output is to
!        start on a new page.
!     integer nfac
!        the number of difference factors.
!     integer nlppa(lagmax)
!        the array of numbers of lagged product pairs used to
!        compute each acf estimate.
!     integer nmiss
!        the number of missing observations.
!     integer ntimes
!        the number of times the first difference factor has been
!        applied.
!     integer nused
!        the active number of observations.
!     real ospvar
!        the one step prediction variance for the order selected (iar).
!     real phi(lagmax)
!        the array of autoregressive coefficients for the selected
!        order.
!     real pmiss
!        the percent of missing observations.
!     real prho(lagmax)
!        the array in which the partial autocorrelations are stored
!     real rho(lagmax)
!        the array in which the autocorrelations are stored
!     real sdrho(lagmax)
!        the array in which the standard errors of the autocorrelations
!        are stored
!     real ymean
!        the mean of the observed series.
!     real ymiss, ymmiss(1)
!        the missing value code.
!     real ysd
!        the standard deviation of the observed series.
!
  implicit none

  real &
     chia,chiap,ospvar,ymean,ymiss,ysd
  integer &
     iar,lagmax,laic,n,ndfchi,nfac,ntimes,nused
  logical &
     differ,ifmiss,newpg
!
!  array arguments
  real &
     aic(laic),ftest(2,lagmax),phi(lagmax),prho(lagmax), &
     rho(lagmax),sdrho(lagmax)
  integer &
     iod(*),nd(*),nlppa(lagmax)
!
!
  real &
     fplm,pmiss
  integer nmiss
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
!
!  external subroutines
  external acfdtl,acflst,aoslst,versp,vpmn

  fplm = huge ( fplm )

  ymmiss(1) = fplm
!
!  print summary information
!

  if (newpg) write( *, 1004)

  call versp (.true.)
  write( *, 1005)
  if (differ) call acfdtl(nfac, nd, iod, ntimes)
  write ( *, 1000) ymean, ysd, n

  if ( ifmiss) then
    nmiss = n - nused
    pmiss = 100.0e0 * real ( nmiss ) / real ( n )
    write ( *, 1003) nmiss, pmiss
  end if

  write ( *, 1006) lagmax
  if (ifmiss) write ( *, 1007) ymiss

  if ( ysd <= 0.0e0 ) then
    write ( *, 1010)
    return
  end if
!
!  print acf information
!
  write ( *, 1008)
  write ( *, 1001)
  call acflst (rho, sdrho, nlppa, lagmax, ifmiss, chia, ndfchi, &
     chiap)
!
!  plot acf information
!
  write ( *, 1004)
  call versp (.true.)
  write ( *, 1001)
  if (differ) then
    call acfdtl(nfac, nd, iod, ntimes)
  end if

  call vpmn ( rho, ymmiss, lagmax, 1, lagmax, 1, 0, isym, 1, 0, &
     -1.0e0, 1.0e0, 1.0e0, 1.0e0, ifmiss, 0, 0, 1)
!
!  check whether pacf have been computed
!
  if (nused <= n-1) return
!
!  print pacf information and autoregressive model order selection
!  statistics
!
  write ( *, 1004)
  call versp (.true.)
  write ( *, 1002)
  write ( *, 1009)
  if (differ) call acfdtl(nfac, nd, iod, ntimes)
  call aoslst (prho, aic, ftest, lagmax, laic, iar, phi, ospvar, &
     .true., n)
!
!  plot pacf information
!
  write ( *, 1004)
  call versp (.true.)
  write ( *, 1002)
  if (differ) then
    call acfdtl(nfac, nd, iod, ntimes)
  end if

  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

 1000 format(/ &
     ' average of the series                 = ', g14.7/ &
     ' standard deviation of the series      = ', g14.7/ &
     ' number of time points                 = ', i10)
 1001 format (' autocorrelation function estimate (acf)'/)
 1002 format (' partial autocorrelation function estimate (pacf)'/)
 1003 format ( &
     ' number of missing observations        = ', i10/ &
     ' percentage of observations missing    = ', f10.4)
 1004 format ('1')
 1005 format ( ' autocorrelation analysis')
 1006 format( &
     ' largest lag value used                = ', i10)
 1007 format( &
     ' missing value code                    = ', g14.7)
 1008 format(//)
 1009 format (' and autoregressive order selection statistics'///)
 1010 format (///' the autocorrelations of this series', &
     ' could not be computed'/ &
     ' because the lag zero autocovariance of the series', &
      ' is zero.')
end
subroutine acfsd ( rho, sdrho, nc, n )

!*****************************************************************************80
!
!! ACFSD computes the standard error of autocorrelations.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer klast
!        the last lag value to be used.
!     integer lag
!        the index variable used to indicate the autocorrelation
!        being examined.
!     integer n
!        the integer number of observations in each series
!     integer nc
!        the number of autocorrelations computed
!     real rho(nc)
!        the array in which the autocorrelations are stored
!     real sdrho(nc)
!        the array in which the standard errors of the autocorrelations
!        are stored
!
  implicit none

  integer &
     n,nc
!
!  array arguments
  real &
     rho(*),sdrho(*)

  integer &
     k,klast,lag

  sdrho(1) = sqrt(real(n - 1)) / real ( n )

  do lag = 2, nc
     sdrho(lag) = 0.0e0
     klast = min(lag-1, n-lag)
     do k = 1, klast
        sdrho(lag) = sdrho(lag) + real (n-lag-k) * rho(k) * rho(k)
     end do
     sdrho(lag) = sqrt(real (n-lag) + 2.0e0 * sdrho(lag)) / real ( n )
  end do

  return
end
subroutine acfsdm ( rho, sdrho, nc, n, nlppa )

!*****************************************************************************80
!
!! ACFSDM computes the standard error of autocorrelations with missing data.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer k
!        an index variable.
!     integer klast
!        the last lag value to be used.
!     integer lag
!        the index variable used to indicate the autocorrelation
!        being examined.
!     integer n
!        the integer number of observations in each series
!     integer nc
!        the number of autocorrelations computed
!     integer nlppa(nc)
!        the array in which the number of observations used to
!        compute each autocorrelation and partial autocorrelation
!        is stored
!     real rho(nc)
!        the array in which the autocorrelations are stored
!     real sdrho(nc)
!        the array in which the standard errors of the autocorrelations
!        are stored
!
  implicit none

  integer &
     n,nc
!
!  array arguments
  real &
     rho(*),sdrho(*)
  integer &
     nlppa(*)
!
!
  integer &
     k,klast,lag

  sdrho(1) = sqrt(real(nlppa(1))) * real (n-1) / real (n * nlppa(1))

  do lag = 2, nc
     sdrho(lag) = 0.0e0
     klast = min(lag-1, n-lag)
     do k = 1, klast
        sdrho(lag) = sdrho(lag) + real (n-lag-k) * rho(k) * rho(k)
     end do
     sdrho(lag) = sqrt ( real (n-lag) + 2.0e0 * sdrho(lag)) * &
        real (n-lag) / real (n*nlppa(lag))
  end do

  return
end
subroutine acfs ( y, n, lagmax, lacov, acov, iar, phi, nprt, ldstak )

!*****************************************************************************80
!
!! ACFS computes autocorrelations with computed ACVF estimates.
!
!  Discussion:
!
!    This is the user callable routine for computing the auto-
!    correlations and partial autocorrelations of a time series
!    with the computed acvf estimates returned to the users
!    routine (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance vector.
!     integer aic
!        the starting location in dstak for
!        the array containing the akaikes criterion for each order.
!     real chia, chiap
!        the variables in which the chi square statistic and
!        chi squared statistic probability for the autocorrelations
!        are stored.
!     logical differ
!        the indicator variable used to designate whether the calling
!        routine is acfd (differ = true) or not (differ = false)
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ftest
!        the starting location in dstak for
!        the array containing the partial f ratio and probabilities
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!     integer ifp
!        the indicator variable used to designate whether the floating
!        point variables are single (ifp=3) or double (ifp=4) precision.
!     integer iod(1)
!        the order of each of the difference factors.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations.
!     integer nd(1)
!        the number of times each difference factor is to be applied
!     integer ndum(1)
!        a dummy dimensioned variable.
!     integer nfac
!        the number of difference factors
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is made.
!     real ospvar
!        the one step prediction variance for the order selected (iar).
!     real phi(lagmax)
!        the array of autoregressive coefficients for the selected
!        order.
!     integer prho
!        the starting location in the work area for prho.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrho
!        the starting location in the work area for sdrho.
!     integer work
!        the starting location in the work area for work.
!     real y(n)
!        the vector containing the observed time series
!     real ymean
!        the mean of the observed time series
!     real ysd
!        the standard deviation of the observed time series
!
  implicit none

  integer &
     iar,lacov,lagmax,ldstak,n,nprt
!
!  array arguments
  real &
     acov(*),phi(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     chia,chiap,ospvar,ymean,ysd
  integer &
     aic,ftest,i,ifp,ldsmin,lyfft,nall0,nfac,nfft,prho, &
     sdrho,work
  logical &
     differ,isfft
!
!  local arrays
  real &
     rstak(12)
  integer &
     iod(1),nd(1),ndum(1)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acfer,acfmn,acfout,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'a',       'c',       'f',       's',       ' ',       ' '/

  ierr = 0
  differ = .false.
  nfac = 1
  nd(1) = 0
  iod(1) = 0
  isfft = .false.
  lyfft = n
  nfft = n

  call ldscmp(4, 0, 0, 0, 0, 0, 's', 5*lagmax+1, ldsmin)

  call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, &
    differ, nfac, nd, iod, isfft, lyfft, nfft)
!
!  check whether an error has been detected
!
  if (ierr==0) then
!
!  set up the work area.
!
    call stkset(ldstak, 4)
    nall0 = stkst(1)

    ifp = 3

    prho = stkget(lagmax, ifp)
    aic = stkget(lagmax+1, ifp)
    ftest = stkget(2*lagmax, ifp)
    work = stkget(lagmax, ifp)
    sdrho = work

    if (ierr==0) then
!
!  call routine for main autocorrelation computations.
!
      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)

      ysd = sqrt (acov(1) * real ( n ) / real ( n - 1 ) )
!
!  call routine to print out autocorrelations
!
      if ((nprt /= 0) .or.  (acov(1)==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)

      if (nprt /= 0) then
        do i = 1, lagmax
           acov(i+1) = acov(i+1) * acov(1)
        end do
      end if

    end if

    call stkclr(nall0)

  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine acvf ( y, n, ymean, acov, lagmax, lacov )

!*****************************************************************************80
!
!! ACVF computes the autocovariance function of a series.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the array in which the autocovariances are stored
!     real dotxy, dotyy
!        the dot product between vectors (y(i) - ymean)) and
!        (y(lag) - ymean)), and (y(i) - ymean)) and (y(i) - ymean)),
!        respectively.
!     integer lacov
!        the actual dimension of acov.
!     integer lag, lagmax
!        the indexing variable indicating the lag value of the
!        autocovariance being computed and the maximum lag to be used,
!        respectively.
!     integer n
!        the number of observations in the series
!     integer ndotxy, ndotyy
!        the number of observations used to compute dotxy and
!        dotyy, respectively.
!     real y(n)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series
!
  implicit none

  real &
     ymean
  integer &
     lacov,lagmax,n
!
!  array arguments
  real &
     acov(lacov),y(*)
!
!
  real &
     dotxy,dotyy
  integer &
     lag,ndotxy,ndotyy
!
!  external subroutines
  external amean,dotc
!
!  compute arithmetic mean
!
  call amean(y, n, ymean)
!
!  compute the variance of the series y
!
  call dotc (y, ymean, n, y, ymean, n, dotyy, ndotyy)
  acov(1) = dotyy / real ( ndotyy )
!
!  Compute autocovariances.
!
  do lag = 1, lagmax
     call dotc (y, ymean, n, y(lag+1), ymean, n - lag, &
         dotxy, ndotxy)
     acov(lag + 1) = dotxy / real ( n )
  end do

  return
end
subroutine acvff ( yfft, n, nfft, ymean, acov, lagmax, lacov, &
  lyfft, work, lwork )

!*****************************************************************************80
!
!! ACVFF computes the ACVF of a series using two FFT passes.
!
!  Discussion:
!
!    This routine computes the acvf of a series using two
!    passes of a fft.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the array in which the autocovariances are stored
!     real fac
!        a factor used in the computations.
!     integer isn
!        an indicator variable used by the fft routines.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag to be used.
!     integer lwork
!        the length of the vector work.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the number of observations in the series
!     integer nf
!        the number of Fourier frequencies.
!     integer nfft
!        the number of observations in the extended series.
!     integer nfft2
!        the effective number of observations for the fft transform.
!     real work(lwork)
!        the work area for the computations.
!     real yfft(lyfft)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series
!
  implicit none

  real &
     ymean
  integer &
     lacov,lagmax,lwork,lyfft,n,nfft
!
!  array arguments
  real &
     acov(lacov),work(*),yfft(lyfft)
!
!
  real &
     fac
  integer &
     i,isn,nf,nfft2
!
!  external subroutines
  external amean,fft,fftct,realtr
!
!     compute arithmetic mean
!
  call amean(yfft, n, ymean)
!
!  Subtract the mean from the series.
!
  yfft(1:n) = yfft(1:n) - ymean
!
!  Append zeros
!
  yfft(n+1:nfft) = 0.0e0
!
!  compute autocovariances.
!
  isn = 2
  nfft2 = (nfft - 2)/ 2

  call fft(yfft(1), yfft(2), nfft2, nfft2, nfft2, isn)
  call realtr (yfft(1), yfft(2), nfft2, isn)

  nf = nfft2 + 1

  do i = 1, nf
     work(i) = yfft(2*i-1)*yfft(2*i-1) + yfft(2*i)*yfft(2*i)
  end do

  call fftct (work, nfft2, lwork)

  fac = 1.0e0 / real ( 4 * ( nfft - 2 ) * n )

  acov(1) = work(1) * fac

  do i = 1, lagmax
     acov(i+1) = work(i+1) * fac
  end do

  return
end
subroutine acvfm ( y, ymiss, n, ymean, acov, lagmax, laglst, nlppa, lacov )

!*****************************************************************************80
!
!! ACVFM computes autocovariance when missing data is involved.
!
!  Discussion:
!
!    This routine computes the autocovariances when missing data are
!    involved.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the array in which the autocovariances are stored
!     real dotxy, dotyy
!        the dot product between vectors (y(i) - ymean)) and
!        (y(lag) - ymean)), and (y(i) - ymean)) and (y(i) - ymean)),
!        respectively.
!     real fplm
!        the floating point largest magnitude.
!     integer lacov
!        the length of the vector acov.
!     integer lag, laglst, lagmax
!        the indexing variable indicating the lag value of the
!        autocorrelation being computed, the number of autocorrelations
!        computed before a missing autocorrelation, and the number of
!        autocorrelations desired, respectively.
!     integer n
!        the integer number of observations in the series
!     integer ndotxy, ndotyy
!        the number of observations used to compute dotxy and
!        dotyy, respectively.
!     integer nlppa(lacov)
!        the array containing the numbers of lagged product pairs
!        used to compute the acvf at each lag.
!     integer nused
!        the number of active observations in the series.
!     real y(n)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series
!     real ymiss
!        the user supplied code which is used to determine whether or
!        not an observation in the series is missing.  if y(i) = ymiss,
!        the value is assumed missing, otherwise it is not.
!
  implicit none

  integer lacov
  integer n

  real acov(lacov)
  real dotxy
  real dotyy
  real fplm
  integer lag
  integer laglst
  integer lagmax
  integer lstlag
  integer ndotxy
  integer ndotyy
  integer nlppa(lacov)
  integer nused
  real y(n)
  real ymean
  real ymiss

  fplm = huge ( fplm )
!
!  Compute arithmetic mean, with missing values taken into account.
!
  call ameanm ( y, ymiss, n, nused, ymean )
!
!  Compute the variance of the series Y.
!
  call dotcm (y, ymean, ymiss, n, y, ymean, ymiss, n, dotyy, ndotyy)

  nlppa(1) = ndotyy

  if ( nlppa(1) == 0 ) then

    laglst = 0

  else

    acov(1) = dotyy / real ( ndotyy )
!
!  Compute autocorrelations, with missing values taken into account.
!
    write ( *, * ) 'LACOV =  ', lacov
    write ( *, * ) 'LAGMAX = ', lagmax
    write ( *, * ) 'N =      ', n

    do 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 ( 0 < nlppa(lag+1) ) then
        acov(lag+1) = dotxy * real ( n - lag ) / real ( nlppa(lag+1) * n )
      end if

    end do
!
!  Find the last autocorrelation to be computed before
!  one could not be computed due to missing data.
!
     laglst = lstlag ( nlppa, lagmax, lacov )

  end if

  return
end
subroutine adjlmt ( ymn, ymx )

!*****************************************************************************80
!
!! ADJLMT corrects the plot limits when all observations are equal.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ymn, ymx
!        the y-axis lower and upper limits actually used.
!
  implicit none

  real ymn
  real ymx

  if (ymn < ymx) return
!
!  correct for all observations identically equal
!
  ymn = ymn - abs(ymn/2.0e0)
  ymx = ymx + abs(ymx/2.0e0)
  if (ymn < ymx) return
  ymn = -0.5e0
  ymx = 0.5e0

  return
end
subroutine aime ( y, n, mspec, nfac, par, npar, res, ldstak )

!*****************************************************************************80
!
!! AIME is the user interface for ARIMA estimation, control call.
!
!  Discussion:
!
!    this is the user callable subroutine for arima estimation
!    (control call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!        if ifixed(1)<0, then ifixed(i)=default,i=1,...,npar, and the
!                           dimension of ifixed will be assumed to be 1.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where for
!        ivaprx le 0, vcv = the default option
!        ivaprx eq 1, vcv = inverse(transpose(j)*j)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 2, vcv = inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 4, vcv = inverse(transpose(j)*j)
!                     using only the model subroutine
!        ivaprx eq 5, vcv = inverse(h)
!                     using only the model subroutine
!        ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using only the model subroutine
!        ivaprx ge 7, vcv = the default option
!        with j representing the jacobian and h the hessian.
!     integer ivcv
!        the first dimension of matrix vcv.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the dimension of vector ifixed.
!     integer lpv
!        the dimension of vector pv.
!     integer lscale
!        the dimension of vector scale.
!     integer lsdpv
!        the dimension of vector sdpv.
!     integer lsdres
!        the dimension of vector sdres.
!     integer lstp
!        the dimension of vector stp.
!     integer mit
!        the maximum number of iterations allowed.
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        the predicted value of the fit, unused when save = false.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(1)
!        the typical size of the parameters.
!        if scale(1) <= 0, then scale(i)=default,i=1,...,npar, and the
!                          dimension of scale will be assumed to be 1.
!     real sdpv(1)
!        the standard deviations of the predicted values, unused
!        when save = false.
!     real sdres(1)
!        the standardized residuals, unused when save = false.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(1)
!        the step size array.
!        if stp(1) <= 0, then stp(i)=default,i=1,...,npar, and the
!                        dimension of stp will be assumed to be 1.
!     real vcv(1,1)
!        the variance-covariance matrix, unused when save = false.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer ldstak
  integer n
  integer nfac
  integer npar

  double precision dstak(12)
  integer ierr
  integer mspec(4,nfac)
  real par(npar)
  real res(n)
  real y(n)

  real &
     delta,rsd,stopp,stopss
  integer &
     ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,mit, &
     npare,nprt
  logical &
     save
!
!  local arrays
  real &
     pv(1),scale(1),sdpv(1),sdres(1),stp(1),vcv(1,1)
  integer &
     ifixed(1)
  character &
     nmsub(6)*1

  external amedrv

  common /cstak/dstak
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'a','i','m','e',' ',' '/

  save = .false.

  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

  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 )

  return
end
subroutine aimec ( y, n, mspec, nfac, par, npar, res, ldstak, &
  ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, nprt )

!*****************************************************************************80
!
!! AIMEC is the user interface for ARIMA estimation.
!
!  Discussion:
!
!    this is the user callable subroutine for arima estimation
!    (control call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!        if ifixed(1)<0, then ifixed(i)=default,i=1,...,npar, and the
!                           dimension of ifixed will be assumed to be 1.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where for
!        ivaprx le 0, vcv = the default option
!        ivaprx eq 1, vcv = inverse(transpose(j)*j)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 2, vcv = inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 4, vcv = inverse(transpose(j)*j)
!                     using only the model subroutine
!        ivaprx eq 5, vcv = inverse(h)
!                     using only the model subroutine
!        ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using only the model subroutine
!        ivaprx ge 7, vcv = the default option
!        with j representing the jacobian and h the hessian.
!     integer ivcv
!        the first dimension of matrix vcv.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the dimension of vector ifixed.
!     integer lpv
!        the dimension of vector pv.
!     integer lscale
!        the dimension of vector scale.
!     integer lsdpv
!        the dimension of vector sdpv.
!     integer lsdres
!        the dimension of vector sdres.
!     integer lstp
!        the dimension of vector stp.
!     integer mit
!        the maximum number of iterations allowed.
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        the predicted value of the fit, unused when save = false.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        the typical size of the parameters.
!        if scale(1) <= 0, then scale(i)=default,i=1,...,npar, and the
!                          dimension of scale will be assumed to be 1.
!     real sdpv(1)
!        the standard deviations of the predicted values, unused
!        when save = false.
!     real sdres(1)
!        the standardized residuals, unused when save = false.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(1)
!        the step size array.
!        if stp(1) <= 0, then stp(i)=default,i=1,...,npar, and the
!                        dimension of stp will be assumed to be 1.
!     real vcv(1,1)
!        the variance-covariance matrix, unused when save = false.
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     delta,stopp,stopss
  integer &
     ivaprx,ldstak,mit,n,nfac,npar,nprt
!
!  array arguments
  real &
     par(*),res(*),scale(*),stp(*),y(*)
  integer &
     ifixed(1),mspec(4,*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     rsd
  integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,npare
  logical &
     save
!
!  local arrays
  real &
     pv(1),sdpv(1),sdres(1),vcv(1,1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external amedrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'a','i','m','e','c',' '/

  save = .false.

  lifixd = npar
  if (ifixed(1) <= -1) lifixd = 1
  lpv = 1
  lscale = npar
  if (scale(1) <= 0.0e0) lscale = 1
  lstp = npar
  if (stp(1) <= 0.0e0) lstp = 1
  lsdpv = 1
  lsdres = 1
  ivcv = 1

  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 )

  return
end
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 )

!*****************************************************************************80
!
!! AIMES is the user interface for ARIMA estimation, long call.
!
!  Discussion:
!
!    this is the user callable subroutine for arima estimation
!    (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!        if ifixed(1)<0, then ifixed(i)=default,i=1,...,npar, and the
!                           dimension of ifixed will be assumed to be 1.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where for
!        ivaprx le 0, vcv = the default option
!        ivaprx eq 1, vcv = inverse(transpose(j)*j)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 2, vcv = inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 4, vcv = inverse(transpose(j)*j)
!                     using only the model subroutine
!        ivaprx eq 5, vcv = inverse(h)
!                     using only the model subroutine
!        ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using only the model subroutine
!        ivaprx ge 7, vcv = the default option
!        with j representing the jacobian and h the hessian.
!     integer ivcv
!        the first dimension of matrix vcv.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the dimension of vector ifixed.
!     integer lpv
!        the dimension of vector pv.
!     integer lscale
!        the dimension of vector scale.
!     integer lsdpv
!        the dimension of vector sdpv.
!     integer lsdres
!        the dimension of vector sdres.
!     integer lstp
!        the dimension of vector stp.
!     integer mit
!        the maximum number of iterations allowed.
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(n)
!        the predicted value of the fit.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        the typical size of the parameters.
!        if scale(1) <= 0, then scale(i)=default,i=1,...,npar, and the
!                          dimension of scale will be assumed to be 1.
!     real sdpv(n)
!        the standard deviations of the predicted values.
!     real sdres(n)
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(npar)
!        the step size array.
!        if stp(1) <= 0, then stp(i)=default,i=1,...,npar, and the
!                        dimension of stp will be assumed to be 1.
!     real vcv(ivcv,npar)
!        the variance-covariance matrix.
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     delta,rsd,stopp,stopss
  integer &
     ivaprx,ivcv,ldstak,mit,n,nfac,npar,npare,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), &
     y(*)
  integer &
     ifixed(1),mspec(4,*)
!
!  scalars in common
  integer &
     ierr

!  arrays in common
  double precision dstak(12)
!

  integer &
     lifixd,lpv,lscale,lsdpv,lsdres,lstp
  logical &
     save
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external amedrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'a','i','m','e','s',' '/

  save = .true.

  if (ifixed(1) <= -1) then
    lifixd = 1
  else
    lifixd = npar
  end if

  if (scale(1) <= 0.0e0) then
    lscale = 1
  else
    lscale = npar
  end if

  if ( stp(1) <= 0.0e0 ) then
    lstp = 1
  else
    lstp = npar
  end if

  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)

  return
end
subroutine aimf ( y, n, mspec, nfac, par, npar, ldstak )

!*****************************************************************************80
!
!! AIMF is the user interface for ARIMA estimation, short call.
!
!  Discussion:
!
!    this is the user callable subroutine for arima estimation
!    (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fcst(1,1)
!        the storage array for the forecasts.
!     real fcstsd(1)
!        the storage array for the standard deviations of the forecasts.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifcst
!        the first dimension of the array fcst.
!     integer ifcsto(1)
!        the indices of the origins for the forecasts.
!     integer ldstak
!        the length of the array dstak.
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     integer nfcst
!        the number of forecasts.
!     integer nfcsto
!        the number of the origins.
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     ldstak,n,nfac,npar
!
!  array arguments
  real &
     par(*),y(*)
  integer &
     mspec(4,*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     ifcst,nfcst,nfcsto,nprt
  logical &
     save
!
!  local arrays
  real &
     fcst(1,1),fcstsd(1)
  integer &
     ifcsto(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external amfcnt
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'a','i','m','f',' ',' '/

  save = .false.

  nfcst = n/10 + 1
  nfcsto = 1
  ifcsto(1) = n
  nprt = -1
  ifcst = 1

  call amfcnt(y, n, mspec, nfac, par, npar, ldstak, nfcst, nfcsto, &
     ifcsto, nprt, fcst, ifcst, fcstsd, nmsub, save)

  return
end
subroutine aimfs ( y, n, mspec, nfac, par, npar, ldstak, &
  nfcst, nfcsto, ifcsto, nprt, fcst, ifcst, fcstsd )

!*****************************************************************************80
!
!! AIMFS is the user interface for ARIMA estimation, control call.
!
!  Discussion:
!
!    this is the user callable subroutine for arima estimation
!    (control call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fcst(ifcst,nfcsto)
!        the storage array for the forecasts.
!     real fcstsd(nfcst)
!        the storage array for the standard deviations of the forecasts.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifcst
!        the first dimension of the array fcst.
!     integer ifcsto(nfcsto)
!        the indices of the origins for the forecasts.
!     integer ldstak
!        the length of the array dstak.
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     integer nfcst
!        the number of forecasts.
!     integer nfcsto
!        the number of the origins.
!     integer nfcstu
!        the number of forcastes actually used.
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     ifcst,ldstak,n,nfac,nfcst,nfcsto,npar,nprt
!
!  array arguments
  real &
     fcst(*),fcstsd(*),par(*),y(*)
  integer &
     ifcsto(*),mspec(4,*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer nfcstu
  logical &
     save
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external amfcnt
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'a','i','m','f','s',' '/

  save = .true.

  if ((nfcst >= 1) .and. (nfcst <= n)) then
     nfcstu = nfcst
  else
     nfcstu = (n/10)+1
  end if

  call amfcnt(y, n, mspec, nfac, par, npar, ldstak, nfcstu, &
     max(1,nfcsto), ifcsto, nprt, fcst, ifcst, fcstsd, nmsub, save)

  return
end
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 )

!*****************************************************************************80
!
!! AIMX1 sets the starting parameter values for the AIMX example.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     real fcst(mxfc,mxfco)
!        the forecasts.
!     real fcstsd(mxfc)
!        the standard deviation of the forecasts.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifcsto(mxfco)
!        the forecast origins.
!     integer ifixed(mxpar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i)==0, then par(i) will be held fixed.
!        ifixed(i)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivcv
!        the actual first dimension of vcv.
!     integer mod
!        an indicator value used to designate the model for which
!        the parameters are to be set.
!     integer mspec(4,mxfac)
!        the values of p, d, q and s for each factor.
!     integer mxfac
!        the maximum number of factors allowed.
!     integer mxfc
!        the maximum number of forecasts allowed.
!     integer mxfco
!        the maximum number of forecasts origins allowed.
!     integer mxn
!        the maximum number of observations allowed.
!     integer mxpar
!        the maximum number of parameters allowed.
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     integer nfcst, nfcsto
!        the number of forecasts and forcast origins.
!     integer npar
!        the number of parameters in the model.
!        to be provided.
!     integer npare
!        the number of parameters estimated by the routine.
!     real par(mxpar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real pv(mxn)
!        the predicted values.
!     real res(mxn)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     real scale(mxpar)
!        the scale values.
!     real sdpv(mxn)
!        the standard deviation of the predicted values.
!     real sdres(mxn)
!        the standardized residuals.
!     real stp(mxpar)
!        the step values.
!     real vcv(mxpar,mxpar)
!        the variance covariance matrix.
!
  implicit none

  integer mxpar

  real delta
  integer ierr
  integer npar
  real par(mxpar)
  real, external :: rmdcon
  real rsd
  external setrv
  real sqmeps
  real stopp
  real stopss

  integer &
     ifcst,ivaprx,ivcv,mit,mod,mxfac,mxfc,mxfco,mxn,n, &
     nfac,nfcst,nfcsto,npare,nprt
!
!  array arguments
  real &
     fcst(mxfc,*),fcstsd(*),pv(*),res(*),scale(*),sdpv(*), &
     sdres(*),stp(*),vcv(mxpar,*)
  integer &
     ifcsto(*),ifixed(*),mspec(4,mxfac)

  common /errchk/ierr

  if ( mod == 1 ) then

    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

  else if ( mod == 2 ) then

    par(1) = 1.0e0
    par(2) = 2.0e0
    par(3) = 3.0e0

  else if ( mod == 3 ) then

    par(1) = 6.0e0
    par(2) = 5.0e0
    par(3) = 4.0e0
    par(4) = 3.0e0
    par(5) = 2.0e0

  else if ( mod == 4 ) then

   call setrv ( par, npar, 0.0e0 )

  else if ( mod == 5 ) then

    call setrv ( par, npar, 0.5e0 )

  else if ( mod == 6 ) then

    par(1) = 100.0e0
    par(2) = 15.0e0

  else

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'AIMX1 - Fatal error!'
    write ( *, '(a)' ) '  Illegal input value of MOD.'
    write ( *, '(a)' ) '  Legal values are 1 through 6.'
    stop

  end if

  sqmeps = sqrt ( epsilon ( sqmeps ) )

  mit = 25
  stp(1:10) = sqmeps
  scale(1:10) = 1.0e0
  stopss = 10.0e-7
  stopp = 10.0e-7
  delta = 0.5e0
  nprt = 11111
  ivaprx = 3
  ivcv = mxpar

  nfcst = 36
  nfcsto = 2
  ifcsto(1) = 103
  ifcsto(2) = n
  ifcst = mxfc

  res(1:mxn) = -1.0e0
  pv(1:mxn) = -1.0e0
  sdpv(1:mxn) = -1.0e0
  sdres(1:mxn) = -1.0e0

  vcv(1:mxpar,1:mxpar) = -1.0e0
  fcstsd(1:mxfc) = -1.0E+00
  fcst(1:mxfc,1:mxfco) = -1.0e0

  npare = -1
  rsd = -1.0e0

  ierr = -1

  return
end
function albeta ( a, b )

!*****************************************************************************80
!
!! ALBETA computes the logarithm of the Beta function.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real a
  real albeta
  real alngam
  real alnrel
  real b
  real corr
  real gamma
  real p
  real q
  real r9lgmc
  real, parameter :: sq2pil = 0.91893853320467274e0

  p = min (a, b)
  q = max (a, b)

  if ( p <= 0.0 ) then
    call xerror ( 'albeta  both arguments must be gt zero', 1, 2)
  end if

  if ( 10.0 <= p ) then

    corr = r9lgmc(p) + r9lgmc(q) - r9lgmc(p+q)

    albeta = -0.5*log(q) + sq2pil + corr + (p-0.5)*log(p/(p+q)) &
      + q*alnrel(-p/(p+q))

  else if ( 10.0 <= q ) then

    corr = r9lgmc(q) - r9lgmc(p+q)

    albeta = alngam(p) + corr + p - p*log(p+q) + &
     (q-0.5)*alnrel(-p/(p+q))

  else

    albeta = log(gamma(p) * (gamma(q)/gamma(p+q)) )

  end if

  return
end
subroutine algams ( x, algam, sgngam )

!*****************************************************************************80
!
!! ALGAMS evaluates the log of the absolute value of the Gamma function.
!
!  Discussion:
!
!    Evaluate log abs (gamma(x)) and return the sign of gamma(x) in sgngam.
!    sgngam is either +1.0 or -1.0.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real algam
  real alngam
  real sgngam
  real x

  algam = alngam ( x )
  sgngam = 1.0

  if ( x <= 0.0 ) then
    if ( int ( real ( mod ( -int ( x ), 2 ) ) + 0.1 ) == 0 ) then
      sgngam = -1.0
    end if
  end if

  return
end
function alngam ( x )

!*****************************************************************************80
!
!! ALNGAM computes the logarithm of the absolute value of the Gamma function.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real alngam
  real x
!
!
  real dxrel,pi,sinpiy,sq2pil,sqpi2l,xmax,y
!
!  external functions
  real gamma,r9lgmc
  external gamma,r9lgmc
!
  data sq2pil / 0.91893853320467274e0/
! sq2pil = log(sqrt(2.*pi)),  sqpi2l = log (sqrt(pi/2.))
  data sqpi2l / 0.22579135264472743e0/
  data pi     / 3.14159265358979324e0/

  data xmax, dxrel / 0., 0. /

  if (xmax == 0.) then
    xmax = huge ( xmax ) / log ( huge ( xmax ) )
    dxrel = sqrt ( epsilon ( dxrel ) )
  end if

  y = abs(x)
!
! log (abs (gamma(x))) for  abs(x) <= 10.0
!
  if ( y <= 10.0 ) then
    alngam = log (abs (gamma(x)))
    return
  end if
!
! log (abs (gamma(x))) for abs(x) > 10.0
!
  if (y > xmax) then
    call xerror ( 'alngam  abs(x) so big alngam overflows', 2, 2)
  end if

  if (x > 0.0) then
     alngam = sq2pil + (x-0.5)*log(x) - x + r9lgmc(y)
     return
  end if

  sinpiy = abs (sin(pi*y))

  if (sinpiy==0.) then
    call xerror ('alngam  x is a negative integer', 3, 2)
  end if

  if (abs((x-aint(x-0.5))/x)<dxrel) then
    call xerror ( &
    'alngam  answer lt half precision because x too near negative integer', &
    1, 1)
  end if

  alngam = sqpi2l + (x-0.5)*log(y) - x - log(sinpiy) - r9lgmc(y)

  return
end
function alnrel ( x )

!*****************************************************************************80
!
!! ALNREL evaluates log ( 1 + X ) with relative error control.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real alnrel
  real x
!
!
  real xmin
  integer nlnrel
!
!  local arrays
  real alnrcs(23)
!
!  external functions
  real csevl
  integer inits
  external csevl,inits
!
!
! series for alnr       on the interval -3.75000d-01 to  3.75000d-01
!                                        with weighted error   1.93e-17
!                                         log weighted error  16.72
!                               significant figures required  16.44
!                                    decimal places required  17.40
!
  data alnrcs( 1) /   1.0378693562743770e0 /
  data alnrcs( 2) /   -.13364301504908918e0 /
  data alnrcs( 3) /    .019408249135520563e0 /
  data alnrcs( 4) /   -.003010755112753577e0 /
  data alnrcs( 5) /    .000486946147971548e0 /
  data alnrcs( 6) /   -.000081054881893175e0 /
  data alnrcs( 7) /    .000013778847799559e0 /
  data alnrcs( 8) /   -.000002380221089435e0 /
  data alnrcs( 9) /    .000000416404162138e0 /
  data alnrcs(10) /   -.000000073595828378e0 /
  data alnrcs(11) /    .000000013117611876e0 /
  data alnrcs(12) /   -.000000002354670931e0 /
  data alnrcs(13) /    .000000000425227732e0 /
  data alnrcs(14) /   -.000000000077190894e0 /
  data alnrcs(15) /    .000000000014075746e0 /
  data alnrcs(16) /   -.000000000002576907e0 /
  data alnrcs(17) /    .000000000000473424e0 /
  data alnrcs(18) /   -.000000000000087249e0 /
  data alnrcs(19) /    .000000000000016124e0 /
  data alnrcs(20) /   -.000000000000002987e0 /
  data alnrcs(21) /    .000000000000000554e0 /
  data alnrcs(22) /   -.000000000000000103e0 /
  data alnrcs(23) /    .000000000000000019e0 /

  data nlnrel, xmin /0, 0./

  if ( nlnrel == 0) then
    nlnrel = inits (alnrcs, 23, 0.05 * epsilon ( x ) )
    xmin = -1.0 + sqrt( epsilon ( xmin ) )
  end if

  if (x <= (-1.0) ) then
    call xerror ( 'alnrel  x is le -1', 2, 2)
  end if

  if (x<xmin) then
    call xerror ( &
      'alnrel  answer lt half precision because x too near -1', 1, 1)
  end if

  if (abs(x) <= 0.375) then
     alnrel = x*(1.0-x*csevl(x/0.375,alnrcs,nlnrel))
  else
     alnrel = log ( 1.0 + x )
  end if

  return
end
subroutine amdrv ( mdlts3, drv, done, ifixd, par, npar, xm, n, m, &
  ixm, nrests, rests, d, weight, wt, lwt, stpt, lstpt, scl, lscl )

!*****************************************************************************80
!
!! AMDRV estimates the jacobian matrix.
!
!  Discussion:
!
!    This routine computes the numerical approximations to the
!    derivative matrix (jacobian).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real d(nrests,npar)
!        the first derivative of the model (jacobian).
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     logical done
!        the variable used to indicate whether this is the final
!        computation of the jacobian or not.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer ixm
!        the first dimension of matrix xm.
!     integer lscl
!        the dimension of vector scl.
!     integer lstpt
!        the dimension of vector stpt.
!     integer lwt
!        the dimension of vector wt.
!     integer m
!        the number of independent variables.
!     external mdlts3
!        the starpac format subroutine for computing the arima model
!        residuals.
!     integer n
!        the number of observations.
!     integer npar
!        the number of parameters in the model.
!     integer nrests
!        the maximum number of residuals to be computed.
!     real par(npar)
!        the current estimates of the parameters.
!     real pj
!        a temporary location for storage of the jth parameter.
!     real rests(nrests)
!        the residuals from the arima model.
!     real scl(lscl)
!        the scale values.
!     real stpt(lstpt)
!        the step size array.
!     real stpj
!        the jth step size.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real xm(ixm,m)
!        the independent variable.
!
  implicit none

  integer ixm
  integer lscl
  integer lstpt
  integer lwt
  integer m
  integer npar
  integer nrests

  real d(nrests,npar)
  logical done
  external drv
  integer ifixd(npar)
  integer j
  integer jpk
  external mdlts3
  integer n
  real par(npar)
  real pj
  real rests(nrests)
  real scl(lscl)
  real stpj
  real stpt(lstpt)
  real xm(ixm,m)
  logical weight
  real wt(lwt)
!
!  Compute finite-difference jacobian of the optimized parameters.
!
  jpk = 0

  do j = 1, npar

    if ( ifixd(j) /= 0 ) then
      cycle
    end if

    jpk = jpk + 1

    pj = par(j)

    if ( scl(jpk) /= 0.0e0 ) then
      stpj = stpt(j) * sign ( 1.0e0, par(j) ) &
        * max ( abs ( par(j) ), 1.0e0 / abs ( scl(jpk) ) )
    else
      if ( par(j) /= 0.0e0 ) then
        stpj = stpt(j) * sign ( 1.0e0, par(j) ) * abs ( par(j) )
      else
        stpj = stpt(j)
      end if
    end if

    stpj = stpj + par(j)
    stpj = stpj - par(j)

    par(j) = pj + stpj

    call mdlts3 ( par, npar, xm, n, m, ixm, d(1:nrests,j) )

    d(1:nrests,jpk) = ( -rests(1:nrests) + d(1:nrests,j) ) / stpj

    par(j) = pj

  end do

  return
end
subroutine amean ( y, n, ymean )

!*****************************************************************************80
!
!! AMEAN computes the arithmetic mean of a series.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer n
!        the number of observations in the series
!     real sumy
!        the variable used to sum the y values.
!     real y(n)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series
!
  implicit none

  integer n

  real y(n)
  real ymean

  ymean = sum ( y(1:n) ) / real ( n )

  return
end
subroutine ameanm ( y, ymiss, n, nused, ymean )

!*****************************************************************************80
!
!! AMEANM computes the arithmetic mean of a series with missing data.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer n
!        the number of observations.
!     integer nused
!        the number of active number of observations.
!     real sumy
!        the variable used to sum the non-missing y values.
!     real y(n)
!        the vector containing the observed series
!     real ymean
!        the mean of the observed time series
!     real ymiss
!        the user supplied code which is used to determine whether or
!        not an observation is missing.  if y(i) = ymiss,
!        the value is assumed missing, otherwise it is not.
!
  implicit none

  real &
     ymean,ymiss
  integer &
     n,nused
!
!  array arguments
  real &
     y(*)
!
!
  real &
     sumy
  integer &
     i
!
!  external functions
  logical &
     mvchk
  external mvchk

  nused = 0
  sumy = 0.0e0
  do i = 1, n
    if ( .not. mvchk ( y(i), ymiss) ) then
      sumy = sumy + y(i)
      nused = nused + 1
    end if
  end do

  if (nused >= 1) then
    ymean = sumy / real ( nused )
  else
    ymean = sumy
  end if

  return
end
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 )

!*****************************************************************************80
!
!! AMECNT is the control routine for nonlinear least squares regression.
!
!  Discussion:
!
!    This is the controlling subroutine for nonlinear least
!    squares regression.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     integer d
!        the starting location in rstak/dstak of
!        the array in which the numerical derivatives with respect to
!        each parameter are stored.
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd
!        the starting location in istak of
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if ifixed(i).eq
!        then par(i) will be held fixed.
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer iiwork
!        the dimension of the integer work vector iwork.
!     integer iptout(5)
!        the variable used to control printed output for each section.
!     integer irwork
!        the dimension of the real work vector rwork.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer iwork
!        the starting location in istak of
!        the integer work space vector used by the nl2 subroutines.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lvcvl
!        the length of the vector containing
!        the lower half of the vcv matrix, stored row wise.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.
!     integer n
!        the number of observations.
!     integer nall0
!        number of allocations on entry.
!     integer ndigit
!        the number of digits in the print control value.
!     external nldrv
!        the name of the routine which calculates the derivatives.
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nrests
!        the maximum number of residuals to be computed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     integer pare
!        the starting location in rstak/dstak of
!        the current estimates of the parameters, but only
!        those to be optimized (not those whose values are fixed).
!     real pv(lpv)
!        the predicted value based on the current parameter estimates
!     integer pvi
!        the starting location in rstak/dstak of
!        the predicted values.
!     real res(n)
!        the residuals from the fit.
!     integer rests
!        the starting location in rstak/dstak of
!        the residuals from the arima model.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer rwork
!        the starting location in rstak/dstak of
!        the real work vector used by the nl2 subroutines.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(lscale)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     integer sdpvi
!        the starting location in rwork of
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     integer sdresi
!        the starting location in rwork of the
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(lstp)
!        the step size array.
!     real vcv(ivcv,npar)
!        the variance-covariance matrix.
!     integer vcvl
!        the starting location in rwork of
!        the variance-covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
  implicit none

  integer n

  logical aprxdv
  real delta
  logical hlfrpt
  integer ierr
  logical page
  real res(n)
  real rsd
  logical save
  real stopp
  real stopss
  logical weight
  logical wide
  real y(n)

  integer &
     ivaprx,ivcv,ixm,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,m, &
     mit,ndigit,nnzw,npar,npare,nrests
!
!  array arguments
  real &
     par(*),pv(lpv),scale(lscale),sdpv(lsdpv),sdres(lsdres),stp(lstp), &
     vcv(ivcv,*),wt(lwt),xm(ixm,*)
  integer &
     ifixed(lifixd),iptout(5)
!
!  subroutine arguments
  external drv,mdl,nldrv,nlhdr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     d,ifixd,ifp,iiwork,irwork,iwork,lvcvl,nall0,pare,pvi, &
     rests,rwork,sdpvi,sdresi,vcvl
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external amemn,cpyasf,scopy,setiv,stkclr
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))

  nall0 = stkst(1)

  ifp = 3

  ierr = 0
!
!  subdivide work area for least squares analysis
!
  iiwork = npare + 60
  irwork = 94 + 2*nrests + npare*(3*npare+33)/2

  ifixd = stkget(npar,2)
  iwork = stkget(iiwork,2)

  d = stkget ( nrests * npar, ifp )
  pare = stkget ( npare, ifp )
  rests = stkget ( nrests, ifp )
  pvi = rests
  rwork = stkget ( irwork, ifp )

  if ( ierr == 1 ) then
    return
  end if
!
!  set values for ifixd
!
  if ( ifixed(1) >= 0 ) then
    call cpyvii(npar, ifixed, 1, istak(ifixd), 1)
  end if

  if ( ifixed(1) < 0 ) then
    call setiv ( istak(ifixd), npar, 0 )
  end if

  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) )

  if ( save ) then

    sdpvi = rwork + sdpvi - 1
    sdresi = rwork + sdresi - 1
    vcvl = rwork + vcvl - 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 cpyasf ( npare, rstak(vcvl), lvcvl, vcv, ivcv )

  end if

  call stkclr ( nall0 )

  return
end
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 )

!*****************************************************************************80
!
!! AMEDRV is the control routine for nonlinear least squares regression.
!
!  Discussion:
!
!    This is the controlling subroutine for nonlinear least
!    squares regression using numerically approximated derivatives.
!
!  Modified:
!
!    28 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     external amehdr
!        the routine used to print the heading
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real exmpt
!        the proportion of observations for which the computed
!        numerical derivatives wrt a given parameter are exempted
!        from meeting the derivative acceptance criteria.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer iflag
!        ...
!     integer ifp
!        an indicator for the precision of the stack allocation type,
!        where ifp=3 indicates single and ifp=4 indicates double.
!     integer iptout(5)
!        the variable used to control printed output for each section.
!     integer is
!        a value used to determine the amount of work space needed
!        based on whether step sizes are input or are to be calculated.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where for
!        ivaprx le 0, vcv = the default option
!        ivaprx eq 1, vcv = inverse(transpose(j)*j)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 2, vcv = inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using both the model subroutine the user supplied
!                     derivative subroutine when it is available
!        ivaprx eq 4, vcv = inverse(transpose(j)*j)
!                     using only the model subroutine
!        ivaprx eq 5, vcv = inverse(h)
!                     using only the model subroutine
!        ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h)
!                     using only the model subroutine
!        ivaprx ge 7, vcv = the default option
!        with j representing the jacobian and h the hessian.
!     integer ivcv
!        the first dimension of matrix vcv.
!     integer ixm
!        the first dimension of matrix xm.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the dimension of vector ifixed.
!     integer lpv
!        the dimension of vector pv.
!     integer lscale
!        the dimension of vector scale.
!     integer lsdpv
!        the dimension of vector sdpv.
!     integer lsdres
!        the dimension of vector sdres.
!     integer lstp
!        the dimension of vector stp.
!     integer lwt
!        the dimension of vector wt.
!     integer m
!        the number of independent variables.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     external mdlts1
!        the starpac format subroutine for computing the arima model
!        predicted values.
!     external mdlts3
!        the starpac format subroutine for computing the arima model
!        residuals.
!     integer mit
!        the maximum number of iterations allowed.
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer mspect
!        the starting location in the work space for
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nall0
!        number of stack allocations outstanding.
!     integer ndigit
!        the number of digits in the print control value.
!     integer neta
!        the number of accurate digits in the model results.
!     integer nfac
!        the number of factors in the model
!     integer nfact
!        the number of factors in the model
!     external nldrvn
!        the name of the routine which calculates the derivatives.
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer npare
!        the number of parameters to be optimized.
!     integer nparma
!        the length of the vector parma
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     integer nrests
!        the maximum number of residuals to be computed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     integer parar
!        the starting location in the work array for
!        the autoregressive parameters
!     integer pardf
!        the starting location in the work space for
!        the vector containing the difference filter parameters
!     integer parma
!        the starting location in the work array for
!        the moving average parameters
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real pv(lpv)
!        the predicted value of the fit.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the residual standard deviation.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(lscale)
!        the typical size of the parameters.
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(lstp)
!        the step size array.
!     external stpamo
!        the routine used to print the output from the step size selecti
!        routines.
!     integer stpt
!        the starting location in /cstak/ of vector stpt containing
!        the step size array.
!     integer t
!        the starting location in the work array for
!        a temporary work vector.
!     integer temp
!        the starting location in the work array for
!        a temporary work vector
!     real vcv(ivcv,npar)
!        the variance-covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(1)
!        the user supplied weights, unused when weight = false.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer n
  integer nfac
  integer npar

  external amehdr
  real delta
  external drv
  double precision dstak(12)
  real exmpt
  integer ierr
  integer ifixed(*)
  integer iflag
  integer ifp
  integer is
  integer isubhd
  integer ivaprx
  integer ivcv
  integer ixm
  integer ldsmin
  integer ldstak
  integer lifixd
  integer lpv
  integer lscale
  integer lsdpv
  integer lsdres
  integer lstp
  integer mbo
  integer mbol
  external mdlts1
  external mdlts3
  integer mit
  integer mspec(4,nfac)
  integer mspect
  integer nfact
  external nldrvn
  character nmsub(6)
  integer nparar
  integer npardf
  integer npare
  integer nparma
  integer nprt
  integer nrests
  real par(npar)
  integer parar
  integer pardf
  integer parma
  real pv(*)
  real res(n)
  real rsd
  logical save
  real scale(*)
  real sdpv(*)
  real sdres(*)
  real stopp
  real stopss
  real stp(*)
  external stpamo
  integer t
  integer temp
  real vcv(*)
  real wt(1)
  real y(n)

  integer &
     lwt,m,nall0,ndigit,neta,nnzw,stpt
  logical &
     aprxdv,hlfrpt,page,prtfxd,weight,wide
!
!  local arrays
  real &
     rstak(12)
  integer &
     iptout(5),istak(12)
!
!  external functions
  integer &
     icnti,stkget,stkst
  external icnti,stkget,stkst
!
!  common blocks
!
  common /cstak/ dstak
  common /errchk/ ierr
  common /mdltsc/ mspect,nfact,pardf,npardf,parar,nparar,parma, &
     nparma,mbo,mbol,t,temp,nrests,iflag
!
!  equivalences
!
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))

  weight = .false.
  wt(1) = 1.0e0
  lwt = 1

  hlfrpt = .false.
  aprxdv = .true.
  prtfxd = .true.
  exmpt = -1.0e0
  neta = 0

  wide = .true.
  page = .false.

  ndigit = 5
!
!  Compute back operators.
!
  call backop ( mspec, nfac, npardf, mbol, mbo, nparma, nparar )
  nnzw = n - npardf

  ierr = 0
  npare = npar

  if ( 0 <= ifixed(1) .and. 1 <= npar ) then
    npare = icnti ( ifixed, npar, 0 )
  end if

  if ( stp(1) <= 0.0e0 ) then
    is = 1
  else
    is = 0
  end if

  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 )

  call ameer ( nmsub, n, npar, npare, ldstak, &
     ldsmin, stp, lstp, scale, lscale, ivcv, save, mspec, nfac )

  if (ierr /= 0) then
    return
  end if

  call stkset ( ldstak, 4 )
!
!  set print control values
!
  call prtcnt ( nprt, ndigit, iptout )
!
!  Subdivide workspace for step sizes.
!
  nall0 = stkst(1)

  ifp = 3

  stpt = stkget ( npar, ifp )

  pardf = stkget ( mbo, ifp )
  parar = stkget ( mbo, ifp )
  parma = stkget ( mbo, ifp )
  t = stkget ( 2 * mbo, ifp )

  temp = t + mbo

  nfact = nfac
  mspect = stkget ( 4 * nfac, 2 )
!
!  Set up for model.
!
  aprxdv = .true.
  m = 1
  ixm = n
  nrests = mbo + 101 + n

  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) )
!
!  Copy supplied step sizes to work space.
!
  call scopy ( lstp, stp, 1, rstak(stpt), 1 )
!
!  Select step sizes, if desired.
!
  if ( ierr == 0 ) then

    isubhd = 1

    if ( stp(1) <= 0.0e0 ) then

      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 )

    end if

    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 )

  end if

  call stkclr(nall0)

  return
end
subroutine ameer ( nmsub, n, npar, npare, ldstak, ldsmin, &
  stp, lstp, scale, lscale, ivcv, save, mspec, nfac )

!*****************************************************************************80
!
!! AMEER checks errors for the nonlinear least squares estimation.
!
!  Discussion:
!
!     this is the error checking routine for nonlinear least squares
!     estimation routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error(20)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        the variable used to indicate whether a heading is to be
!        printed during a given call to the iteration report (true)
!        or not (false).
!     integer i
!        an index variable.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ivcv
!        the first dimension of matrix vcv.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 livcv(8), llds(8), lmspec(8), ln(8), lnfac(8),
!    *   lnpar(8), lnpare(8), lone(8), lscl(8), lstep(8), lzero(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer lscale
!        the dimension of vector scale.
!     integer lstp
!        the dimension of vector stp.
!     integer mspec(4,*)
!        integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model.
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer np
!        the number of parameters specified by mspec.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     integer nv
!        *
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(lscale)
!        the typical size of the parameters.
!     real stp(lstp)
!        the step size array.
!
  implicit none

  integer &
     ivcv,ldsmin,ldstak,lscale,lstp,n,nfac,npar,npare
  logical &
     save
!
!  array arguments
  real &
     scale(*),stp(*)
  integer &
     mspec(4,*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,np,nv
  logical &
     head
!
!  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
!
!  external subroutines
  external eiage,eiseq,eisge,ervgt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',' ',' ',' ',' '/
!
!  Error checking
!
  error(1:20) = .false.

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 1, 2, head, error(1), lone)

  call eisge(nmsub, lnfac, nfac, 1, 2, head, error(2), lone)

  if (.not. error(2)) &
    call eiage(nmsub, lmspec, mspec, 4, nfac, 4, 0, 0, head, 1, nv, &
    error(3), lmspec)

  if ((.not. error(2)) .and. (.not. error(3))) then
    np = 1
    do i = 1, nfac
      np = np + mspec(1,i) + mspec(3,i)
    end do
    call eiseq(nmsub, lnpar, npar, np, 1, head, error(4), lnpar)

    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

  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)

  do i=1,20
    if (error(i)) then
      ierr = 1
      return
    end if
  end do

  return
end
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 )

!*****************************************************************************80
!
!! AMEFIN analyzes nonlinear least squares estimates after they are computed.
!
!  Discussion:
!
!    this routine completes the analysis for the nonlinear
!    least squares estimation routines once the estimates
!    have been found.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real cond
!        the condition number of d.
!     real d(n,npar)
!        the first derivative of the model (jacobian).
!     logical exact
!        an indicator value used to designate whether the fit
!        was exact to machine precision (true) or not (false).
!     external amehdr
!        the routine used to print the heading
!     integer idf
!        the degrees of freedom in the fit.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer iskull(10)
!        an error message indicator variable.
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!     integer ixm
!        the first dimension of matrix xm.
!     integer lvcvl
!        the dimension of vector vcvl.
!     integer lwt
!        the dimension of vector wt.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     integer nrests
!        the maximum number of residuals to be computed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     logical prtfsm
!        the variable used to indicate whether any of the summary
!        information is to be printed (true) or not (false).
!     real pvt(n)
!        the predicted value based on the current parameter estimates.
!     real rd(n)
!        the diagonal elements of the r matrix of the q - r
!        factorization of d.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the residual standard deviation.
!     real rss
!        the residual sum of squares.
!     real rsshlf
!        half the residual sum of squares.
!     real sdpvt(n)
!        the standard deviations of the predicted values.
!     real sdrest(n)
!        the standardized residuals.
!     real vcvl(lvcvl)
!        the lower half of the variance-covariance matrix, stored
!        row wise.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real xm(ixm,m)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!     real yss
!        the sum of the squares about the mean y value.
!
  implicit none

  real &
     rsd,rsshlf
  integer &
     ivcvpt,ixm,lvcvl,lwt,m,n,ndigit,nnzw,npar,npare,nrests
  logical &
     page,weight,wide
!
!  array arguments
  real &
     d(n,*),par(*),pvt(*),rd(*),res(*),sdpvt(*),sdrest(*),vcvl(*), &
     wt(*),xm(ixm,m),y(*)
  integer &
     ifixd(*),iptout(*),iskull(10)
!
!  subroutine arguments
  external amehdr
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     cond,rss,yss
  integer idf
  logical &
     exact,prtfsm
!
!  common blocks
  common /errchk/ierr
!
!  Modify vcv to reflect proper degrees of freedom
!
  vcvl(1:lvcvl) = real (nrests-npar) * vcvl(1:lvcvl) / real(n-npar)
!
!  Compute returned and/or printed values.
!
  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)

  prtfsm = ((iptout(3) /= 0) .or. (iptout(4) /= 0) .or. &
     (iptout(5) /= 0) .or. (ierr /= 0))
!
!  Print summary information if desired or if an error flag
!  has been set.
!
  if ( prtfsm ) then
    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)
  end if

  return
end
subroutine amehdr ( page, wide, isubhd )

!*****************************************************************************80
!
!! AMEHDR prints headings for nonlinear least squares estimation.
!
!  Discussion:
!
!    This routine prints the page headings for the nonlinear
!    least squares estimation routines for arima models that use
!    numerical approximations to the derivatives.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide
!
!  external subroutines
  external versp

  if (page) write (*, 1020)
  call versp(wide)
  if (page) write (*,1000)
  if (.not.page) write (*,1010)
  page = .true.

  if (isubhd==0) return

  write ( *, 1030)

  return

 1000 format ('+nonlinear least squares estimation', &
     ' for the parameters of an arima model, continued')
 1010 format ('+', 77('*')/ &
     1x, '*  nonlinear least squares estimation', &
     ' for the parameters of an arima model  *'/ &
     ' *', 16x, '             using backforecasts             ', &
     14x, '*'/1x, 77('*'))
 1020 format ('1')
 1030 format (//' summary of initial conditions'/ 1x, 30('-'))
end
subroutine ameism ( amehdr, page, wide, hlfrpt, npar, m, n, nnzw, &
  weight, ifixd, par, scale, lscale, iwork, liwork, rwork, &
  lrwork, res, aprxdv, stpt, lstpt, npare )

!*****************************************************************************80
!
!! AMEISM prints an initial summary for nonlinear least squares routines.
!
!  Discussion:
!
!    This routine prints an initial summary of the starting
!    estimates and the control parameters for the nonlinear
!    least squares subroutines for arima modeling.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     external amehdr
!        the routine used to print the heading
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer iamhd
!        the indicator value used to designate the type of list
!        to be generated
!        if iamhd=1, the list is for the initial summary of the
!                    estimation routines.
!        if iamhd=2, the list is for the initial report of the
!                    forecasting routines.
!        if iamhd=3, the list is for the final report of the
!                    estimation routines.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer iwork(liwork)
!        work space used by the nl2 subroutines.
!     integer liwork
!        the dimension of vector iwork.
!     integer lmax0
!        the location in rwork of the value indicating the
!        maximum change allowed in the model parameters at the
!        first iteration.
!     integer lrwork
!        the dimension of vector rwork.
!     integer lscale
!        the dimension of vector scale.
!     integer lstpt
!        the dimension of vector stpt.
!     integer m
!        a dummy variable.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     integer mspect
!        the starting location in the work space for
!        the array containing the values of p, d, q, and s for each fact
!     integer mxfcal
!        the location in iwork of the variable designating the
!        maximum number of function calls allowed, excluding
!        calls necessary to compute the derivatives and variance
!        covariance matrix.
!     integer mxiter
!        the location in iwork of the variable designating the
!        maximum number of iterations allowed.
!     integer n
!        the number of observations.
!     integer nfact
!        the number of factors in the model
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer npare
!        the number of parameters to be optimized.
!     integer nparma
!        the length of the vector parma
!     integer nrests
!        the maximum number of residuals to be computed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     integer parar
!        the starting location in the work array for
!        the autoregressive parameters
!     integer pardf
!        the starting location in the work space for
!        the vector containing the difference filter parameters
!     integer parma
!        the starting location in the work array for
!        the moving average parameters
!     real res(n)
!        the residuals from the fit.
!     integer rfctol
!        the location in rwork of the relative function convergence
!        tolerance.
!     real rsd
!        the residual standard deviation.
!     real rss
!        the residual sum of squares.
!     real rwork(lrwork)
!        work space used by the nl2 subroutines.
!     real scale(lscale)
!        the typical size of the parameters.
!     real stpt(lstpt)
!        the step size array.
!     integer t
!        the starting location in the work array for
!        a temporary work vector.
!     integer temp
!        the starting location in the work array for
!        a temporary work vector
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     integer xctol
!        the location in rwork of the parameter convergence tolerance.
!
  implicit none

  integer &
     liwork,lrwork,lscale,lstpt,m,n,nnzw,npar,npare
  logical &
     aprxdv,hlfrpt,page,weight,wide
!
!  array arguments
  real &
     par(*),res(*),rwork(lrwork),scale(*),stpt(*)
  integer &
     ifixd(*),iwork(liwork)
!
!  subroutine arguments
  external amehdr
!
!  scalars in common
  integer &
     iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma,nrests, &
     parar,pardf,parma,t,temp
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     rsd,rss
  integer &
     iamhd,isubhd,lmax0,mxfcal,mxiter,rfctol,xctol
!
!  local arrays
  integer &
     istak(12)
!
!  external functions
  real &
     snrm2
  external snrm2
!
!  external subroutines
  external amlst,modsum
!
!  common blocks
  common /cstak/dstak
  common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, &
     nparma,mbo,mbol,t,temp,nrests,iflag
!
!  equivalences
  equivalence (dstak(1),istak(1))
!
!     iwork subscript values
!
  data mxfcal/17/, mxiter/18/
!
!     rwork subscript values
!
  data lmax0/35/, rfctol/32/, xctol/33/

  isubhd = 1
  call amehdr(page, wide, isubhd)

  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)

  if (weight) write ( *, 1170) nnzw
  write ( *, 1070) iwork(mxiter)
  write ( *, 1090) iwork(mxfcal)
  write ( *, 1080)
  write ( *, 1100) rwork(rfctol)
  write ( *, 1110) rwork(xctol)
  write ( *, 1120) rwork(lmax0)
  rsd = snrm2(nrests, res, 1)
  rss = rsd * rsd
  if (n-npardf-npare >= 1) &
       rsd = rsd / sqrt(real(n-npardf-npare))
  write ( *, 1200) rss
  write ( *, 1210) rsd
  write ( *, 1220) n, npardf, npare, nnzw-npare

  return

 1070 format (/' maximum number of iterations allowed', 32x, '(mit)', &
     1x, i5)
 1080 format(/' convergence criterion for test based on the'/)
 1090 format(/' maximum number of model subroutine calls', &
     ' allowed', 26x, i5)
 1100 format (5x, ' forecasted relative change in residual', &
     ' sum of squares', 7x, '(stopss)', 1x, g11.4)
 1110 format(5x, ' maximum scaled relative change in the parameters', &
     13x, '(stopp)', 1x, g11.4)
 1120 format(//' maximum change allowed in the parameters', &
     ' at the first iteration', 3x, '(delta)', 1x, g11.4)
 1170 format (/' number of non zero weighted observations', 27x, &
     '(nnzw)', 1x, i5)
 1200 format (/' residual sum of squares for input parameter', &
     ' values', 24x, g11.4, '  (backforecasts included)')
 1210 format (/' residual standard deviation for input parameter', &
     ' values', 14x, '(rsd)', 1x, g11.4)
 1220 format (/ ' based on degrees o', &
     'f freedom', 1x, i4, ' - ', i3, ' - ', i3, ' = ', i4)
end
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 )

!*****************************************************************************80
!
!! AMEMN is the control routine for using the NL2 software package.
!
!  Discussion:
!
!    This is the controling subroutine for performing nonlinear
!    least squares regression using the nl2 software package
!    (implementing the method of dennis, gay and welsch).
!
!    This routine was adapted from subroutine nl2sol.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    Algorithm 573:
!    An Adaptive Nonlinear Least-Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981, pages 367-383.
!
!  Parameters:
!
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     logical cmpdrv
!        the variable used to indicate whether derivatives must be
!        computed (true) or not (false).
!     integer cnvcod
!        a value used to control the printing of iteration reports.
!     integer covmat
!        the location in iwork of the starting location in rwork
!        of the beginning of the vcv matrix.
!     real d(nrests,npar)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     logical done
!        the variable used to indicate whether this is the final
!        computation of the jacobian or not.
!     logical head
!        the variable used to indicate whether a heading is to be
!        printed during a given call to the iteration report (true)
!        or not (false).
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer i
!        an indexing variable.
!     integer icnvcd
!        the location in iwork of
!        the convergence condition.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer iiwork
!        the dimension of the integer work vector iwork.
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer irwork
!        the dimension of the real work vector rwork.
!     integer iskull(10)
!        an error message indicator variable.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!     integer iwork(iiwork)
!        the integer work space vector used by the nl2 subroutines.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer lscale
!        the actual length of the vector scale.
!     integer lstp
!        the actual length of the vector stp.
!     integer lvcvl
!        the length of the vector containing
!        the lower half of the vcv matrix, stored row wise.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdlts3
!        the starpac format subroutine for computing the arima model
!        residuals.
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     logical newitr
!        a flag used to indicate whether a new iteration has been
!        completed (true) or not (false).
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     integer nrests
!        the maximum number of residuals to be computed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     real pare(npar)
!        the current estimates of the parameters, but only
!        those to be optimized (not those whose values are fixed).
!     logical prtsmy
!        the variable used to indicate whether the summary
!        information is to be printed (true) or not (false).
!     real pvt(n)
!        the predicted value based on the current parameter estimates.
!     integer qtr
!        the location in iwork of the starting location in rwork
!        the array q transpose r.
!     integer rd
!        the location in iwork of the starting location in rwork of
!        the diagonal elements of the r matrix of the q - r
!        factorization of d.
!     integer rdi
!        the location in rwork of the diagonal elements of the r
!        matrix of the q - r factorization of d.
!     real res(n)
!        the residuals from the fit.
!     real rests(nrests)
!        the residuals from the arima model.
!     integer rsave
!        the location in iwork of the starting location in rwork
!        the array rsave.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     integer rsshlf
!        the location in rwork of
!        half the residual sum of squares.
!     real rwork(irwork)
!        the real work vector used by the nl2 subroutines.
!     integer s
!        the location in iwork of the starting location in rwork
!        the array of second order terms of the hessian.
!     real scale(lscale)
!        the typical size of the parameters.
!     integer scl
!        the index in rwork of the 1st value of the user supplied scale
!        value.
!     integer sdpvi
!        the starting location in rwork of
!        the standard deviations of the predicted values.
!     integer sdresi
!        the starting location in rwork of the
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!        predicted decrease in the residual standard deviation (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stopss
!        the stopping criterion forthe test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(lstp)
!        the dummy step size array.
!     integer vcvl
!        the starting location in rwork of the lower half of the
!        vcv matrix, stored row wise.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
  implicit none

  integer nrests

  real delta
  real rests(nrests)
  real rsd
  real stopp
  real 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

  real &
     d(nrests,*),par(*),pare(*),pvt(*),res(*),rwork(*), &
     scale(*),stp(*),wt(*),xm(ixm,*),y(*)
  integer &
     ifixd(*),iptout(*),iwork(*)
!
!  subroutine arguments
  external nlhdr
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     cnvcod,covmat,icnvcd,ivcvpt,qtr,rd,rdi,rsave,rsshlf,s, &
     scl
  logical &
     cmpdrv,done,head,newitr,prtsmy
!
!  local arrays
  integer &
     iskull(10)
!
!  external subroutines
  external amdrv,amefin,ameism,drv,mdlts3,nl2itr,nlerr,nlinit, &
     nlitrp,nlsupk,repck,scopy
!
!  common blocks
  common /errchk/ierr
!
!     iwork subscript values
!
  data cnvcod /34/, icnvcd /1/, covmat /26/, qtr /49/, rd /51/, &
     rsave /52/, s/53/
  data rsshlf /10/
!
!  initialize control parameters
!
  call nlinit (nrests, ifixd, par, npar, pare, npare, mit, stopss, &
     stopp, scale, lscale, delta, ivaprx, aprxdv, ivcvpt, iwork, &
     iiwork, rwork, irwork, scl)

  cmpdrv = .true.
  done = .false.
  head = .true.
  newitr = .false.
  prtsmy = (iptout(1) /= 0)
!
!  compute residuals
!
   10 continue

  call mdlts3 ( par, npar, xm, n, m, ixm, rests )
!
!  print initial summary
!
  if ( prtsmy) then

    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.
  end if

  if (.not.cmpdrv) go to 50

  cmpdrv = .false.

   40 continue
!
!  print iteration report if desired
!
  if ((iptout(2) /= 0) .and. newitr) then
    call nlitrp ( nlhdr, head, page, &
      wide, iptout(2), npar, nnzw, iwork, iiwork, rwork, irwork, &
      ifixd, pare, npare )
  end if
!
!  compute jacobian
!
  if ( done ) then
    call mdlts3 ( par, npar, xm, n, m, ixm, rests )
  end if

  call amdrv ( mdlts3, drv, done, ifixd, par, npar, xm, n, m, ixm, &
    nrests, rests, d, weight, wt, lwt, stp, lstp, rwork(scl), npare )

  if (done) go to 70
!
!  compute next iteration
!
   50 call nl2itr(rwork(scl), iwork, d, nrests, nrests, npare, rests, &
     rwork, pare)
!
!  unpack parameters
!
  call nlsupk ( pare, npare, par, ifixd, npar )

  newitr = (iwork(cnvcod)==0)
  if (iwork(1)-2) 10, 40, 60

   60 done = .true.
  go to 40
   70 continue
!
!  set error flags, if necessary
!
  call nlerr(iwork(icnvcd), iskull)
!
!  finish computations and print any desired results
!
  call scopy(n, rests(nrests-n+1), 1, res(1), 1)
  pvt(1:n) = y(1:n) - res(1:n)
  sdpvi = iwork(rsave)
  sdresi = iwork(qtr)
  vcvl = iwork(covmat)

  if (vcvl >= 1) go to 80

  vcvl = iwork(s)

  if ( ierr == 0) then
    iskull(1) = 1
    iskull(7) = 1
    ierr = 7
  end if

   80 continue

  lvcvl = npare*(npare+1)/2

  rdi = iwork(rd)
!
!  repck is called to avoid modification of nls code.  future
!  revisions of nls code should include modifications necessary
!  to eliminate need to repack d for arima code.
!
  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)

  return
end
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 )

!*****************************************************************************80
!
!! AMEOUT prints the final summary output from ARIMA estimation.
!
!  Discussion:
!
!    This routine prints the final summary output from the
!    arima estimation subroutines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real cond
!        the condition number of d.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical exact
!        an indicator value used to designate whether the fit
!        was exact to machine precision (true) or not (false).
!     real fplm
!        the floating point largest magnitude.
!     external amehdr
!        the routine used to print the heading
!     integer i
!        an index variable.
!     integer iamhd
!        the indicator value used to designate the type of list
!        to be generated
!        if iamhd=1, the list is for the initial summary of the
!                    estimation routines.
!        if iamhd=2, the list is for the initial report of the
!                    forecasting routines.
!        if iamhd=3, the list is for the final report of the
!                    estimation routines.
!     integer idf
!        the degrees of freedom in the fit.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer iskull(10)
!        an error message indicator variable.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!     integer lvcvl
!        the dimension of vector vcvl.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     integer mspect
!        the starting location in the work space for
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     integer nfact
!        the number of factors in the model
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer npare
!        the number of parameters to be optimized.
!     integer nparma
!        the length of the vector parma
!     integer nrests
!        the maximum number of residuals to be computed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     integer parar
!        the starting location in the work array for
!        the autoregressive parameters
!     integer pardf
!        the starting location in the work space for
!        the vector containing the difference filter parameters
!     integer parma
!        the starting location in the work array for
!        the moving average parameters
!     real pvt(n)
!        the predicted value based on the current parameter estimates.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the residual standard deviation.
!     real rss
!        the residual sum of squares.
!     real sdpvt(n)
!        the standard deviations of the predicted values.
!     real sdrest(n)
!        the standardized residuals.
!     integer t
!        the starting location in the work array for
!        a temporary work vector.
!     integer temp
!        the starting location in the work array for
!        a temporary work vector
!     real vcvl(lvcvl)
!        the lower half of the variance-covariance matrix, stored
!        row wise.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real y(n)
!        the dependent variable.
!     real yss
!        the sum of the squares about the mean y value.
!
  implicit none

  real &
     cond,rsd,rss,yss
  integer &
     idf,ivcvpt,lvcvl,n,ndigit,npar,npare
  logical &
     exact,page,wide
!
!  array arguments
  real &
     par(*),pvt(*),res(*),sdpvt(*),sdrest(*),vcvl(*),y(*)
  integer &
     ifixd(*),iptout(*),iskull(10)
!
!  subroutine arguments
  external amehdr
!
!  scalars in common
  integer &
     ierr,iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, &
     nrests,parar,pardf,parma,t,temp
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     fplm
  integer iamhd,isubhd
!
!  local arrays
  integer &
     istak(12)
!
!  external subroutines
  external amept1,amept2,amlst,modsum,nlskl,vcvotf
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
  common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, &
     nparma,mbo,mbol,t,temp,nrests,iflag
!
!  equivalences
  equivalence (dstak(1),istak(1))

  fplm = huge ( fplm )

  if ((ierr >= 1) .and. (ierr /= 4)) go to 60
!
!  Test for exact fit
!
  if ((idf <= 0) .or. exact) go to 70
!
!  Print error heading if necessary
!
  if (ierr == 4 ) then
    call nlskl(iskull, page, wide, amehdr)
  end if
!
!  Print primary report
!
  if ( (ierr/=0) .or. (iptout(3)/=0)) then
    isubhd = 0
    call amehdr(page, wide, isubhd)
    call amept1(n, y, pvt, sdpvt, res, sdrest, iptout, ndigit)
  end if
!
!  print standardized residual plots
!
  if ( iptout(4) /= 0 ) then

    isubhd = 0
    call amehdr(page, wide, isubhd)

    call amept2 (res, sdrest, n, rss)

  end if
!
!  print the covariance and correlation matrix
!
  if ((ierr==0) .and. (iptout(5)==0)) return
  isubhd = 0
  call amehdr(page, wide, isubhd)
  call modsum(nfact, istak(mspect))

  if ( ierr /= 0 .or. 1 < iptout(5) ) then

    call vcvotf(npare, vcvl, lvcvl, .true., npar, ifixd, ivcvpt)

  end if
!
!  print analysis summary
!
  write ( *,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 ( *,1050) cond

  if (rss > yss) write ( *,1060)

  return
!
!  print out error heading
!
   60 continue

  call nlskl(iskull, page, wide, amehdr)

  if (ierr <= 2) return
!
!  print secondary report
!
   70 continue

  isubhd = 0
  call amehdr(page, wide, isubhd)
  call modsum(nfact, istak(mspect))
  if (ierr /= 0) write ( *,1080)
  write ( *,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 /= 3) write ( *,1050) cond

  if ((ierr==0) .and. (.not.exact) .and. (idf <= 0)) then
    write ( *, 1070)
  end if

  if ((ierr==0) .and. exact) write ( *,1090)

  if (ierr == 0) then
    sdrest(1:n) = 0.0e0
    sdpvt(1:n) = 0.0e0
    return
  end if

  sdrest(1:n) = fplm
  sdpvt(1:n) = fplm
!
!  print out error exit statistics
!
  call amept1(n, y, pvt, sdpvt, res, sdrest, iptout, ndigit)
!
!  Wipe out sdrest vector
!
  sdrest(1:n) = fplm
!
!  wipe out vcv matrix
!
  vcvl(1:lvcvl) = fplm

  return

 1000 format (///' estimates from least squares fit'/1x, 33('-'))
 1050 format (/' approximate condition number', 10x, g15.7)
 1060 format (//' the residual sum of squares after the least squares', &
     ' fit is greater than'/' the sum of squares about the mean ', &
     'y observation.  the  model is less'/' representative o', &
     'f the data than a simple average.  data and model shou', &
     'ld'/' be checked to be sure that they are compatible.')
 1070 format (/' the degrees of freedom for this problem is zero.', &
     '  statistical analysis of the results is not possible.')
 1080 format (//' the following summary should be used to  analyze', &
     ' the above mentioned problems.')
 1090 format (/' the least squares fit of the data to the model is', &
     ' exact to within machine precision.'/' statistical analysi', &
     's of the results is not possible.')
end
subroutine amept1 ( n, y, pvt, sdpvt, res, sdrest, iptout, ndigit )

!*****************************************************************************80
!
!! AMEPT1 prints data summary for nonlinear least squares routines.
!
!  Discussion:
!
!    This routine prints the data summary for the nonlinear
!    least squares subroutines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index variable.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     integer nmax
!        the maximum number of rows to be printed.
!     real pvt(n)
!        the predicted value based on the current parameter estimates.
!     real res(n)
!        the residuals from the fit.
!     real sdpvt(n)
!        the standard deviations of the predicted values.
!     real sdrest(n)
!        the standardized residuals.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     n,ndigit
!
!  array arguments
  real &
     pvt(*),res(*),sdpvt(*),sdrest(*),y(*)
  integer &
     iptout(*)
!
!  scalars in common
  integer &
     ierr

  integer &
     i,nmax
!
!  external subroutines
  external obssm2
!
!  common blocks
  common /errchk/ierr

  write ( *,1100)
  write ( *,1000)
  write ( *, 1110)

  nmax = n
  if ((max(iptout(3),1)==1) .and. (n >= 45)) &
    nmax = min(n,40)
!
!  print observation summary
!
  call obssm2(n, y, pvt, sdpvt, res, sdrest, 1, nmax)

  if ( nmax < n ) then

    do i = 1, 3
       write ( *, 1150)
    end do

    call obssm2(n, y, pvt, sdpvt, res, sdrest, n, n)

  end if

  if ((ierr==4)) write ( *, 1080)
  if ((ierr > 0) .and. (ierr /= 4)) write ( *, 1090)

  return

 1000 format (/ 5x, 16x, '  -----predicted  ----std dev of', 16x, &
     '  ---std'/ &
     2x, 'row', '  --------series  ---------value', &
     '  ----pred value  ------residual  ---res')
 1080 format (// ' *  nc  -  value not computed because', &
     ' the standard deviation of the residual is zero.')
 1090 format (// ' *  nc  -  value not computed', &
     ' because convergence problems prevented the covariance', &
     ' matrix from being computed.')
 1100 format (//' results from least squares fit'/ 1x, 31('-'))
 1110 format (' ')
 1150 format (4x, '.', 4(15x, '.'), 7x, '.')
end
subroutine amept2 ( res, sdrest, n, rss )

!*****************************************************************************80
!
!! AMEPT2 prints four standardized residual plots.
!
!  Discussion:
!
!    This routine, adapted from omnitab ii, prints
!    the four standardized residual plots.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real an
!        the number of observations, used in computing
!        the normal probability plot.
!     real dot
!        the dot product used to compute the correlation coefficient.
!     real fac1, fac2
!        factors used in computing the normal probability plot.
!     real fplm
!        the floating point largest magnitude.
!     real gamma
!        a value used in computing the normal probability plot.
!     integer i
!        an index variable.
!     character*1 iblank
!        the value of the character -blank-.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer imid
!        the midpoint of the autocorrelation plot.
!     character*1 iminus
!        the character minus.
!     integer iplot
!        an indicator variable designating whether the first or
!        second set of two plots are being printed.
!     character*1 iplus
!        the character plus.
!     integer iprb
!        the location in the plot string of the symbol for the
!        probability plot.
!     integer irow
!        the row of the variables being plotted.
!     character*1 istar
!        the character star.
!     integer ix
!        the location in the plot string of the symbol for the plots
!        versus the independent variable.
!     integer i1, i2
!        index values.
!     integer k
!        an index variable.
!     integer l
!        an index variable.
!     character*1 line(113)
!        the symbols (blanks and characters) for a given line
!        of the plot.
!     integer n
!        the number of observations.
!     integer ncol, ncolpl, ncolp1, ncolt2
!        the number of columns in the plot, ncol+l, ncol+1,
!        and ncol * 2.
!     integer ndot
!        the number of points making up dot.
!     integer nrow
!        the number of columns in the plot.
!     real pi
!        the value of pi.
!     real ratio
!        a value used to produce the normal probability plot.
!     real res(n)
!        the residuals from the fit.
!     real rowdiv
!        the value of a division along the -row- axis.
!     real rowmax
!        the largest row value.
!     real rowmid
!        the midpoint of the range of the rows plotted.
!     real rowmin
!        the smallest row value plotted.
!     real rss
!        the residual sum of squares.
!     real sdrest(n)
!        the standardized residuals.
!     real ylabel
!        the label to be printed along the y axis.
!     real ymax
!        the largest value along the y axis
!     real ymin
!        the smallest value along the y axis.
!
  implicit none

  real &
     rss
  integer &
     n
!
!  array arguments
  real &
     res(*),sdrest(*)
!
!  scalars in common
  integer &
     ierr

  real &
     an,dot,fac1,fac2,fplm,gamma,pi,ratio,rowdiv,rowmax,rowmid, &
     rowmin,ylabel,ymax,ymin
  integer &
     i,i1,i2,imid,iplot,iprb,irow,ix,k,l,ncol,ncolp1, &
     ncolpl,ncolt2,ndot,nrow
  character &
     iblank*1,iminus*1,iplus*1,istar*1
!
!  local arrays
  character &
     line(113)*1
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  external subroutines
  external dotc,getpi
!
!  common blocks
  common /errchk/ierr

  data iplus/'+'/, iminus/'-'/, istar/'*'/, iblank/' '/

  fplm = huge ( fplm )
!
!  check for insufficient points to plot
!
  if (ierr /= 4) go to 20

  do i = 1, n
     if (sdrest(i) /= fplm) go to 20
  end do
  write ( *, 1090)
  return

   20 continue
!
!  initialize values for probability plot
!
  call getpi(pi)
  gamma = pi/8.0e0
  an = real ( n )
  fac1 = 1.0e0 / (an - 2.0e0*gamma + 1.0e0)
  fac2 = 10.0e0
!
!  initialize the plot size (in plot units)
!
  nrow = 26
!
!  begin computations for first set of plots
!
  iplot = 1
  ncol = 111
!
!  set x axis limits for standardized residual vs row plot,
!
  rowmin = 1.0
  rowmax =  real ( n )

  rowmid = (rowmax+rowmin) / 2.0e0
  rowdiv = (rowmax-rowmin) / real ( ncol - 1 )
!
!  print titles for first plots
!
  write ( *,1000)
  go to 90
!
!  begin computations for second set of plots
!
   40 iplot = 2
  ncol = 51
!
!  print titles for second plots
!
  write ( *,1050)
!
!  write first line of plots
!
   90 continue
!
!  print plots, one line at a time
!
  ncolp1 = ncol + 1
  ncolt2 = 2*ncol
  ylabel = 3.75e0
  ymax = fplm
  ymin = 4.05e0

  do k = 1, nrow

     ymin = ymin - 0.3e0
     if (-3.70e0 >= ymin) ymin = -fplm

     do l=1,ncol

        ncolpl = l + ncol
        line(l) = iblank
        if (iplot==2) line(ncolpl) = iblank

        if ( k == 1 .or. k == nrow ) then

           line(l) = iminus
           if (iplot==2) line(ncolpl) = iminus

           if ( (mod(l,10) == 1) .or. (l == 1+ncol/2) ) then
              line(l) = iplus
              if (iplot==2) line(ncolpl) = iplus
           end if

         end if

     end do

     do i=1,n
        if (.not.mvchk(sdrest(i),fplm)) then
           if ((sdrest(i) > ymin) .and. (sdrest(i) <= ymax)) then
              if (iplot==1) then
                  irow = int(((real ( 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 <= ncol) iprb = ncol+1
                  if (iprb >= 103) iprb = 102
                  line(iprb) = istar
                  an = an - 1.0e0
                  if ((an<2.0e0) .and. (n <= 10)) then
                     gamma = 1.0e0/3.0e0
                  end if
               end if
            end if
         end if
      end do
!
!  set plot line for correlation plot of second set of plots
!
     if (iplot==2) then
        imid = (ncol-1)/2
        if (k <= n-1) then
           dot = 0.0e0
           call dotc(res, 0.0e0, n, res(k+1), 0.0e0, &
                     n-k, dot, ndot)
           ix = int(real ( imid ) *dot/rss) + imid + 1
           i1 = min(ix,imid+1)
           i2 = max(ix,imid+1)
           line(i1:i2) = istar
        end if
     end if

     if (mod(k,5)==1) then
        if (iplot==1) then
           write ( *,2020) ylabel, (line(l),l=1,ncol)
        else
           write ( *,1020) k, (line(l),l=1,ncol), ylabel, &
                             (line(l),l=ncolp1,ncolt2)
        end if
        ylabel = ylabel - 1.5e0
     else
        if (iplot==1) then
           write ( *,2030) (line(l),l=1,111)
        else
           write ( *,1030) (line(l),l=1,102)
        end if
     end if
     ymax = ymin

  end do
!
!  print bottom line of graphs
!
  if (iplot==1) then
!
!  print x axis labels for first set of plots
!
     write ( *,1040) rowmin, rowmid, rowmax
     go to 40
!
!  print x axis labels for second set of plots
!
  else
     write ( *,1070)
  end if

  return

 1000 format (/51x, ' 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, ' normal probability plot of std res' )
 1070 format (4x, '-1.00', 22x, '0.0', 21x, '1.00', 5x, '-2.5', 23x, &
     '0.0', 22x, '2.5')
 1090 format (// 1x, 13('*')/ 1x, 'h*  warning  *'/ 1x, 13('*')// &
     ' the standardized residual plots have been suppressed.', &
     '  none of the standardized residuals could be', &
     ' computed,'/ &
     ' because for each observation either the weight or', &
     ' the standard deviation of the residual is zero.')
 2020 format (1x, f5.2, '+', 111a1, '+')
 2030 format (6x, '-', 111a1, '-')
end
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 )

!*****************************************************************************80
!
!! AMESTP controls the step size selection.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer cd
!        the starting location in the work area of
!        the central difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real eta
!        the relative noise in the model.
!     real exm
!        the proportion of observations actually used for which the
!        computed numerical derivatives wrt a given parameter are
!        exempted from meeting the derivative acceptance criteria.
!     real exmpt
!        the proportion of observations for which the computed
!        numerical derivatives wrt a given parameter are exempted
!        from meeting the derivative acceptance criteria.
!     integer fd
!        the starting location in the work area of
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     integer fdlast
!        the starting location in the work area of
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!        for the last step size tried.
!     integer fdsave
!        the starting location in the work area of
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!        for the best step size tried so far.
!     real fplrs
!        the floating point largest relative spacing.
!     external hdr
!        the name of the routine which produces the heading
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifailj
!        the starting location in istak for
!        the array of indicator variables designating whether
!        the setp size selected was satisfacotry for a given
!        observation and the jth parameter.
!     integer ifixd
!        the starting location in /cstak/ of vector ifixd containing
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer ifp
!        an indicator for the precision of the stack allocation type,
!        where ifp=3 indicates single and ifp=4 indicates double.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer itemp
!        the starting location in istak for
!        a temporary storage vector.
!     integer ixm
!        the first dimension of matrix xm.
!     integer j
!        an index variable.
!     integer lifixd
!        the dimension of vector ifixed.
!     integer lscale
!        the dimension of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer mxfail
!        the maximum number of failures for any parameter.
!     integer n
!        the number of observations.
!     integer nall0
!        number of stack allocations outstanding.
!     integer ndd
!        the number of decimal digits carried for a single
!        precision real number.
!     integer ndgt1
!        the number of reliable digits in the model used, either
!        set to the user supplied value of neta, or computed
!        by etamdl.
!     integer neta
!        the number of accurate digits in the model results.
!     integer nexmpt
!        the number of observations for which a given step size
!        does not have to be satisfactory and the selected step
!        size still be considered ok.
!     integer nfail
!        the number of observations for which the selected step size
!        for the parameter does not meet the criteria.
!     integer nfailj
!        the number of observations for which the selected step size
!        for the jth parameter does not meet the criteria.
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     integer partmp
!        the starting location in the work area of
!        the modified model parameters
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     integer pv
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!     integer pvmcd
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!     integer pvnew
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpnew.
!     integer pvpad
!       additional workspace needed in pv for the evaluation of the
!       model.
!     integer pvpcd
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpcd.
!     integer pvstp
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stp(j).
!     integer pvtemp
!        the starting location in the work area of
!        a tempory storage location for predicted values begins.
!     real q
!        a dummy variable which is used, along with common notopt (no
!        optimization), to compute the step size.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real scale(lscale)
!        the typical size of the parameters.
!     real scl
!        the actual typical size used.
!     real stp(npar)
!        the selected step sizes.
!     external stpout
!        the routine for printing the output.
!     real tau
!        the agreement tolerance.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real xm(ixm,m)
!        the independent variable.
!
  implicit none

  integer ixm
  integer lifixd

  real exmpt
  external hdr
  logical head
  integer isubhd
  integer lscale
  integer m
  integer n
  integer neta
  integer npar
  integer nprt
  integer pvpad

  logical &
     hlfrpt,page,prtfxd,wide
!
!  array arguments
  real &
     par(*),scale(*),stp(*),xm(ixm,*)
  integer &
     ifixed(lifixd)
!
!  subroutine arguments
  external mdl,stpout
!
!  scalars in common
  real &
     q
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  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
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external functions

  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external etamdl,setiv,stkclr,stpmn
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
  common /notopt/ q
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))

  nall0 = stkst(1)
  fplrs = epsilon ( fplrs )
  ifp = 3
!
!  set print controls
!
  head = .true.
!
!  subdivide work area
!
  ifixd = stkget(npar, 2)
  itemp = stkget(n, 2)
  ifailj = stkget(n, 2)
  nfail = stkget(npar, 2)

  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)

  if ( ierr == 1 ) then
    return
  end if

  partmp = cd
!
!  set up ifixd
!
  if ( ifixed(1)<0 ) then
    call setiv(istak(ifixd), npar, 0)
  else
    call cpyvii(npar, ifixed, 1, istak(ifixd), 1)
  end if
!
!  Set parameters necessary for the computations
!
  ndd = int(-log10(fplrs))

  if ((neta  >=  2) .and. (neta <= 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

  tau = min ( eta**0.25e0, 0.01e0 )

  exm = exmpt
  if ((exm<0.0e0) .or. (exm > 1.0e0)) then
    exm = 0.10e0
  end if

  nexmpt = int ( exm * real ( n ) )
  if (exm  /=  0.0e0) then
    nexmpt = max(nexmpt, 1)
  end if
!
!  Compute predicted values of the model using the input parameter
!  estimates
!
  call mdl ( par, npar, xm, n, m, ixm, rstak(pv) )

  mxfail = 0
  nfailj = nfail

  do j = 1, npar

    if ( scale(1) <= 0.0e0 ) then
      if ( par(j) == 0.0e0 ) then
        scl = 1.0e0
      else
        scl = abs ( par(j) )
      end if
    else
      scl = scale(j)
    end if
!
!  Select step size.
!
    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) )
!
!  Compute the maximum number of failures for any parameter.
!
    mxfail = max ( istak(nfailj), mxfail )
!
!  Print results if they are desired.
!
    if ( nprt /= 0 .or. mxfail > nexmpt )  then
      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) )
    end if

    nfailj = nfailj + 1

  end do

  hlfrpt = .false.
  if ( nprt /= 0 .or. mxfail > nexmpt ) then
    hlfrpt = .true.
  end if

  if ( mxfail > nexmpt ) then
    ierr = 2
  end if

  call stkclr ( nall0 )

  return
end
subroutine amfcnt ( y, n, mspec, nfac, par, npar, ldstak, &
  nfcst, nfcsto, ifcsto, nprt, fcst, ifcst, fcstsd, nmsub, save )

!*****************************************************************************80
!
!! AMFCNT is the control routine for ARIMA forecasting.
!
!  Discussion:
!
!    This is the controlling subroutine for forecasting using arima models.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer f
!        the starting location in the work vector for
!        the forecasts.
!     real fcst(ifcst,nfcsto)
!        the storage array for the forecasts.
!     real fcstsd(nfcst)
!        the storage array for the standard deviations of the forecasts.
!     integer fsd
!        the starting location in the work vector for
!        the standard deviations of the forecasts.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifcst
!        the first dimension of the array fcst.
!     integer ifcsto(nfcsto)
!        the indices of the origins for the forecasts.
!     integer ifp
!        an indicator for the precision of the stack allocation type,
!        where ifp=3 indicates single and ifp=4 indicates double.
!     integer is
!        a value used to determine the amount of work space needed
!        based on whether step sizes are input or are to be calculated.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer mspect
!        the starting location in the work space for
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nall0
!        number of stack allocations outstanding.
!     integer nfac
!        the number of factors in the model
!     integer nfact
!        the number of factors in the model
!     integer nfcst
!        the number of forecasts.
!     integer nfcsto
!        the number of the origins.
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer nparma
!        the length of the vector parma
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     integer parar
!        the starting location in the work array for
!        the autoregressive parameters
!     integer pardf
!        the starting location in the work space for
!        the vector containing the difference filter parameters
!     integer parma
!        the starting location in the work array for
!        the moving average parameters
!     integer pv
!        the starting location in the work array for
!        the predicted values
!     integer nrests
!        the maximum number of residuals to be computed.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     integer t
!        the starting location in the work array for
!        a temporary work vector.
!     integer temp
!        the starting location in the work array for
!        a temporary work vector
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     ifcst,ldstak,n,nfac,nfcst,nfcsto,npar,nprt
  logical &
     save
!
!  array arguments
  real &
     fcst(*),fcstsd(*),par(*),y(*)
  integer &
     ifcsto(*),mspec(4,*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr,iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, &
     nrests,parar,pardf,parma,t,temp
!
!  arrays in common
  double precision dstak(12)

  integer &
     f,fsd,ifp,ldsmin,nall0,pv
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external amfer,amfmn,backop,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
  common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, &
     nparma,mbo,mbol,t,temp,nrests,iflag
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!  compute back operators
!
  call backop(mspec, nfac, npardf, mbol, mbo, nparma, nparar)

  ierr = 0

  call ldscmp(8, 0, 4*nfac, &
     0, 0, 0, 's', 5*mbo + 2*nfcst + n + mbo + 101, ldsmin)

  call amfer(nmsub, n, npar, ldstak, ldsmin, save, mspec, nfac, &
     ifcst, nfcst)

  if (ierr==0) then

    call stkset(ldstak, 4)
!
!  subdivide workspace for step sizes
!
    nall0 = stkst(1)

    ifp = 3

    pardf = stkget(mbo, ifp)
    parar = stkget(mbo, ifp)
    parma = stkget(mbo, ifp)
    t = stkget(2*mbo, ifp)

    temp = t + mbo

    nfact = nfac
    mspect = stkget(4*nfac, 2)
    f = stkget(nfcst, ifp)
    fsd = stkget(nfcst, ifp)
!
!  set up for model
!
    nrests = mbo + 101 + n
    pv = stkget(nrests, ifp)

    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 main routine for computing and printing forecasts
!
    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

  call stkclr(nall0)

  return
end
subroutine amfer ( nmsub, n, npar, ldstak, ldsmin, &
  save, mspec, nfac, ifcst, nfcst )

!*****************************************************************************80
!
!! AMFER checks errors for nonlinear least squares estimation.
!
!  Discussion:
!
!    This is the error checking routine for nonlinear least squares
!    estimation routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error(20)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        the variable used to indicate whether a heading is to be
!        printed during a given call to the iteration report (true)
!        or not (false).
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 lifcst(8), llds(8), lmspec(8), ln(8), lnfac(8),
!    *  lnpar(8), lnfcst(8), lone(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     integer nfcst
!        the number of forecasts.
!     character*1 nmsub(6)
!        the name of the routine calling the error checking routine
!     integer npar
!        the number of parameters in the model.
!     integer nv
!        *
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!
  implicit none

  integer &
     ifcst,ldsmin,ldstak,n,nfac,nfcst,npar
  logical &
     save
!
!  array arguments
  integer &
     mspec(4,*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr

  integer &
     i,np,nv
  logical &
     head
!
!  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
!
!  external subroutines
  external eiage,eiseq,eisge
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' ',' '/
!

  error(1:20) = .false.

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 1, 2, head, error(1), lone)

  call eisge(nmsub, lnfac, nfac, 1, 2, head, error(2), lone)

  if (.not. error(2)) &
    call eiage(nmsub, lmspec, mspec, 4, nfac, 4, 0, 0, head, 1, nv, &
    error(3), lmspec)

  if ((.not. error(2)) .and. (.not. error(3))) then
    np = 1
    do i = 1, nfac
       np = np + mspec(1,i) + mspec(3,i)
    end do
    call eiseq(nmsub, lnpar, npar, np, 1, head, error(4), lnpar)
  end if

  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)

  if (save) &
     call eisge(nmsub, lifcst, ifcst, nfcst, 3, head, error(15), &
     lnfcst)

  do i=1,20
    if (error(i)) then
      ierr = 1
      return
    end if
  end do

  return
end
subroutine amfhdr ( page, wide, isubhd )

!*****************************************************************************80
!
!! AMFHDR prints headers for nonlinear least squares estimation.
!
!  Discussion:
!
!    This routine prints the page headings for the nonlinear
!    least squares estimation routines for arima models that use
!    numerical approximations to the derivatives.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide

  if (page) write ( *, 1020)
  call versp(wide)
  if (page) write ( *,1000)
  if (.not.page) write ( *,1010)
  page = .true.

  if (isubhd==0) return

  write ( *, 1030)

  return

 1000 format ('+arima forecasting, continued')
 1010 format ('+', 23('*')/ ' *  arima forecasting  *', /1x, 23('*'))
 1020 format ('1')
 1030 format (//' model summary'/' -------------')
end
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 )

!*****************************************************************************80
!
!! AMFMN computes and prints ARIMA forecasts.
!
!  Discussion:
!
!    This is the main routine for computing and printing the arima forecasts
!
!  Modified:
!
!    24 April 2007
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real const
!        the constant term in the model, modeling either the series
!        mean or a deterministic trend.
!     real f(nfcst)
!        the forecasts.
!     real fcst(ifcst,nfcsto)
!        the storage array for the forecasts.
!     real fcstsd(nfcst)
!        the storage array for the standard deviations of the forecasts.
!     real fsd(nfcst)
!        the standard deviations of the forecasts.
!     integer i
!        an index variable.
!     integer if
!        an index variable.
!     integer ifcst
!        the first dimension of the array fcst.
!     integer ifcsto(nfcsto)
!        the indices of the origins for the forecasts.
!     integer iflag
!        an indicator variable designating whether the back forecasts
!        were essentially zero (iflag=0) or not (iflag=1).
!     integer ifo
!        the index of the origin being used.
!     integer ifomin
!        the smallest origin used.
!     integer i1
!        an index value.
!     integer j
!        an index variable.
!     integer k
!        an index variable.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     integer mspect(nfac,4)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     integer nfcst
!        the number of forecasts.
!     integer nfcsto
!        the number of the origins.
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer nparma
!        the length of the vector parma
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     integer nt
!        the number of parameters in t, where nt = mbol
!     integer n1
!        the lower bound for pv.
!     integer n2
!        the upper bound for pv.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     real parar(mbo)
!        the autoregressive parameters
!     real pardf(npardf)
!        the vector containing the difference filter parameters.
!     real parma(mbo)
!        the moving average parameters
!     real pmu
!        the value of mu, i.e., the trend or mean.
!     real pv(n1:n2)
!        the predicted value of the fit.
!     real rsd
!        the residual standard deviation.
!     real rss
!        the residual sum of squares.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real t(2*mbo)
!        a temporary work vector.
!     real temp(mbo)
!        a temporary work vector
!     real t975
!        the value of the 97.5 percent point function for the
!        t distribution.
!     real wsum
!        the sum of the weights squared, used to compute the
!        standard deviation of the forecast.
!     real wsumt
!        a temporary storage location for wsum.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer npar

  integer ifcst
  integer ifixd(npar)

  integer mbo,mbol,n,n1,n2,nfac,nfcst,nfcsto,nparar, &
     npardf,nparma,nprt
  logical &
     save
!
!  array arguments
  real &
     f(*),fcst(ifcst,*),fcstsd(*),fsd(*),par(*),parar(*),pardf(*), &
     parma(*),pv(n1:n2),t(*),temp(*),y(*)
  integer &
     ifcsto(*),mspect(nfac,4)

  real &
     const,pmu,rsd,rss,t975,wsum,wsumt
  integer &
     i,i1,idf,if,ifc,iflag,ifo,ifomin,j,k,nt
  logical &
     page
!
!  external functions
  real &
     ppft,sdot
  external ppft,sdot
!
!  external subroutines
  external amfhdr,amfout,amlst,dcoef,mdlts2,modsum,multbp
!
!  Set IFIXD to zero.  
!  I simply inserted this variable here; it wasn't in the original,
!  but AMLST seems to expect it.  
!  JVB, 24 April 2007.
!
  ifixd(1:npar) = 0
!
!  Compute differencing parameters
!
  call dcoef (nfac, mspect(1,2), mspect(1,4), npardf, pardf, mbo, t)
!
!  compute residuals, given values of parameters
!
  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 / real ( idf ) )
!
!  print initial summary
!
  page = .false.

  if ( nprt /= 0 ) then

    call amfhdr ( page, .true., 2 )

    call modsum ( nfac, mspect )

    call amlst ( 2, par, npar, nfac, mspect, n, par, npar, par, &
      npar, par, npar, ifixd, rss, rsd, npardf, npar, idf )

    page = .true.

  end if
!
!  combine pardf and parar into t
!
  nt = nparar + npardf
  call multbp(parar, nparar, pardf, npardf, t, nt, mbo)
!
!  compute constant
!
  const = 0.0e0
  if (pmu /= 0.0e0) then
    if (nparar >= 1) then
      do j = 1, nparar
        const = const - parar(j)
      end do
    end if
    const = (1.0e0 + const) * pmu
  end if
!
!  find lowest origin
!
  ifomin = minval ( ifcsto(1:nfcsto) )
!
!  set temp to backforecast of y if necessary
!
  if ((mbol >= 1) .and. (ifomin<mbol)) then
    i1 = ifomin-mbol+1

    do i = 0, i1, -1

      k = 1-i
      temp(k) = const

      do j = 1, mbol
        if (i+j <= n) then
          if (i+j >= 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
      end do

      if (nparma >= 1) then
        do j =1, nparma
          if (i+j <= n) temp(k) = temp(k) - parma(j)*pv(i+j)
        end do
      end if

    end do

  end if
!
!  compute weights for computing standard deviations of the forecast
!
  do j = 1, nfcst
    fsd(j) = 0.0e0
    if (mbol >= 1) then
      do i = 1, mbol
        if (j-i >= 1) then
          fsd(j) = fsd(j) + t(i)*fsd(j-i)
        else
          if (j-i==0) fsd(j) = fsd(j) + t(i)
        end if
      end do
    end if
    if (j <= nparma) fsd(j) = fsd(j) - parma(j)
  end do
!
!  compute standard deviations of forecasts.
!
  wsum = 1.0e0
  do i = 1, nfcst
    wsumt =wsum
    wsum = wsum + fsd(i)*fsd(i)
    fsd(i) = sqrt(wsumt)*rsd
  end do
!
!  set percent point value for 95 percent confidence limits.
!
  t975 = ppft(0.975e0, n-npar)
!
!  compute forecasts for each origin.
!
  do ifo = 1, nfcsto

    ifc = ifcsto(ifo)
    if ((ifc<1) .or. (ifc > n)) ifc = n

    do if = 1, nfcst

      f(if) = const

      if (mbol >= 1) then
        do j = 1, mbol
          k = if + ifc-j
          if (k <= 0) then
            f(if) = f(if) + t(j)*temp(1-k)
          else
            if (k <= ifc) then
              f(if) = f(if) + t(j)*y(k)
            else
              f(if) = f(if) + t(j)*f(if-j)
            end if
          end if
        end do
      end if

        do j = 1, nparma
          k = if + ifc - j
          if (k <= ifc) f(if) = f(if) - parma(j)*pv(k)
        end do

      if (save) fcst(if,ifo) = f(if)

    end do
!
!  Print results from this origin.
!
    if (nprt /= 0) then
      call amfout(f, fsd, n, nfcst, ifcsto, ifo, nfcsto, y, t975, &
      page)
    end if

  end do

  return
end
subroutine amfout ( f, fsd, n, nfcst, ifcsto, ifo, nfcsto, y, t975, page )

!*****************************************************************************80
!
!! AMFOUT produces ARIMA forecasting output.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real f(nfcst)
!        the forecasts.
!     real fl
!        the lower 95 percent confidence limit for the forecast
!     real fsd(nfcst)
!        the standard deviations of the forecasts.
!     real fu
!        the upper 95 percent confidence limit for the forecast
!     integer i
!        an index variable.
!     integer iend
!        the last location in the plot string.
!     integer if
!        an index variable.
!     integer ifcsto(nfcsto)
!        the indices of the origins for the forecasts.
!     integer ifo
!        the index of the origin being used.
!     integer ilim
!        the number of locations in ylim.
!     integer inter
!        the number of plot intervals.
!     integer ipf
!        the location in the plot string of the forecast.
!     integer ipfl
!        the location in the plot string of the forecast lower
!        confidence limit.
!     integer ipfu
!        the location in the plot string of the forecast upper
!        confidence limit.
!     integer ipy
!        the location in the plot string of the observed value.
!     integer iy
!        an index variable.
!     integer j
!        an index variable.
!     character*1 line(53)
!        the array of symbols to be plotted.
!     integer n
!        the number of observations.
!     integer nfcst
!        the number of forecasts.
!     integer nfcsto
!        the number of the origins.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real scale
!        the plot scale.
!     real t975
!        the value of the 97.5 percent point function for the
!        t distribution.
!     real y(n)
!        the dependent variable.
!     real ylim(4)
!        the values of the axis labels.
!     real ymn
!        the minimum value to be plotted.
!     real ymx
!        the maximum value to be plotted.
!
  implicit none

  logical page
  real t975
  integer &
     ifo,n,nfcst,nfcsto
!
!  array arguments
  real &
     f(nfcst),fsd(*),y(*)
  integer &
     ifcsto(nfcsto)
!
!
  real &
     fl,fu,scale,ymn,ymx
  integer &
     i,iend,if,ilim,inter,ipf,ipfl,ipfu,ipy,iy,j
!
!  local arrays
  real &
     ylim(4)
  character &
     line(53)*1
!
!  external subroutines
  external amfhdr
!
!  set variables for plots
!
  inter = 50
  iend = inter + 1
  ilim = 4
!
!  Compute scale for plot.
!
  ymn = f(nfcst)-t975*fsd(nfcst)
  ymx = f(nfcst)+t975*fsd(nfcst)
  iy = ifcsto(ifo)
  do i = 1, nfcst
    ymn = min(ymn, f(i)-t975*fsd(i))
    ymx = max(ymx, f(i)+t975*fsd(i))
    if ((iy >= 1) .and. (iy <= n)) then
      ymn = min(ymn, y(iy))
      ymx = max(ymx, y(iy))
      iy = iy + 1
    end if
  end do

  if (ifcsto(ifo) >= 2) then
    do iy = max(ifcsto(ifo)-4, 1), ifcsto(ifo)-1
      ymn = min(ymn, y(iy))
      ymx = max(ymx, y(iy))
    end do
  end if

  scale = (ymx-ymn) / real ( inter )
!
!  print plot headings
!
  do i = 1, ilim
    ylim(i) = ymn + scale * real ( i ) * 10.0e0
  end do

  call amfhdr(page, .true., 0)
  write ( *, 1030) ifo
  write ( *, 1000) ymn, ylim(2), ylim(4), &
    ylim(1), ylim(4), ymx
!
!  begin plotting
!
  do i=max(ifcsto(ifo)-4,1), ifcsto(ifo)+nfcst

     if (i /= ifcsto(ifo)) then
       line(1:iend) = ' '
     else
       line(1:iend) = '.'
     end if

     if (i <= ifcsto(ifo)) then
       ipy = int(((y(i)-ymn) / scale) + 1.5e0)
       line(ipy) = '*'
       write ( *, 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 <= n) then
         ipfl = int(((fl-ymn) / scale) + 1.5e0)
         ipfu = int(((fu-ymn) / scale) + 1.5e0)
         line(ipfl:ipfu) = '-'
         line(ipfl) = '('
         line(ipfu) = ')'
         ipy = int(((y(i)-ymn) / scale) + 1.5e0)
         line(ipy) = '*'
         ipf = int(((f(if)-ymn) / scale) + 1.5e0)
         if (ipf /= ipy) then
           line(ipf) = 'x'
         else
           line(ipf) = '2'
         end if
         write ( *, 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)
         line(ipfl:ipfu) = '-'
         line(ipfl) = '('
         line(ipfu) = ')'
         ipf = int(((f(if)-ymn) / scale) + 1.5e0)
         line(ipf) = 'x'
         write ( *, 1010) i, (line(j),j=1,iend), i, &
           f(if), fl, fu
       end if
     end if
  end do

  return

 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)

end
subroutine amlst1 ( iamhd, par, npar, mspect, nfac, vcvl, lvcvl, &
  scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd )

!*****************************************************************************80
!
!! AMLST1 prints parameters for the ARIMA routine.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     character*1 fixed(3)
!        the characters used to label the parameters fixed or not.
!     real fplm
!        the floating point largest magnitude.
!     integer iamhd
!        the indicator value used to designate the type of list
!        to be generated
!        if iamhd=1, the list is for the initial summary of the
!                    estimation routines.
!        if iamhd=2, the list is for the initial report of the
!                    forecasting routines.
!        if iamhd=3, the list is for the final report of the
!                    estimation routines.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer iparmn
!        the smallest parameter index included in this term.
!     integer iparmx
!        the largest parameter index included in this term.
!     integer lvcvl
!        the dimension of vector vcvl.
!     integer j
!        an index variable.
!     integer l
!        an index variable.
!     integer lbltyp
!        the type of lable to be printed, where
!        1 indicates the term is autoregressive and
!        2 indicates the term is moving average
!     integer ll
!        an index variable.
!     integer lpar
!        an index variable.
!     integer lscale
!        the dimension of vector scale.
!     integer lstpt
!        the dimension of vector stpt.
!     integer mspect(nfac,4)
!        the array containing the values of p, d, q, and s for each fact
!     integer nfac
!        the number of factors in the model
!     integer npar
!        the number of parameters in the model.
!     integer order
!        the order of b for the parameter being printed
!     real par(npar)
!        the current estimates of the parameters.
!     real pll
!        the lower confidence limit for a given parameter.
!     real pul
!        the upper confidence limit for a given parameter.
!     real ratio
!        the ratio of a given parameter value to its standard error.
!     real scale(lscale)
!        the typical size of the parameters.
!     real sdpar
!        the standard deviation of a given parameter value.
!     real stpt(lstpt)
!        the step size array.
!     real t975
!        the value of the 97.5 percent point function for the
!        t distribution.
!     real vcvl(lvcvl)
!        the lower half of the variance-covariance matrix, stored
!        row wise.
!
  implicit none

  real &
     t975
  integer &
     iamhd,iparmn,iparmx,lbltyp,lscale,lstpt,lvcvl,nfac,npar
!
!  array arguments
  real &
     par(npar),scale(lscale),stpt(lstpt),vcvl(lvcvl)
  integer &
     ifixd(*),mspect(nfac,4)
!
!
  real &
     fplm,pll,pul,ratio,sdpar
  integer &
     j,k,l,ll,lpar,order
!
!  local arrays
  character &
     fixed(3)*1

  fplm = huge ( fplm )
!
!  print next set of terms
!
  lpar = 0
  do j=1,iparmx
    if ( ifixd(j) == 0 ) then
      lpar = lpar + 1
    end if
  end do

  do j=1,nfac

    if ((mspect(j,lbltyp)==0) .and. (lbltyp /= 2)) then
      cycle
    end if

    if (lbltyp /= 2) iparmx = iparmx + mspect(j,lbltyp)
    if (lbltyp==2) iparmx = iparmx + 1
    order = 0

    do l = iparmn, iparmx

      order = order + mspect(j,4)

      if ( iamhd == 2 ) then

        if (lbltyp==1) then
          write ( *, 1010) l, j, order, par(l)
        else if (lbltyp==2) then
          write ( *, 1014) l, par(l)
        else if (lbltyp==3) then
          write ( *, 1015) l, j, order, par(l)
        end if

      else

        call fixprt(ifixd(l), fixed)

        if (lbltyp==1) then
          write ( *, 1000) l, j, order, (fixed(k),k=1,3), par(l)
        else if (lbltyp==2) then
          write ( *, 1004) l, (fixed(k),k=1,3), par(l)
        else if (lbltyp==3) then
          write ( *, 1005) l, j, order, (fixed(k),k=1,3), par(l)
        end if

          if (iamhd/=3) then

            if (ifixd(l)/=0) then

              write ( *, 1007)

            else

              if (scale(1) <= 0.0e0 ) then
                write ( *, 1001) stpt(l)
              else
                write ( *, 1002) scale(l), stpt(l)
              end if

            end if

          end if

          if ( iamhd /= 1 ) then

            if ( ifixd(l) == 0 ) then

              lpar = lpar + 1
              ratio = fplm
              ll = lpar*(lpar-1)/2 + lpar
              if (vcvl(ll) > 0.0e0) ratio = par(l)/sqrt(vcvl(ll))
              sdpar = sqrt(vcvl(ll))
              pll = par(l) - t975*sdpar
              pul = par(l) + t975*sdpar
              write ( *, 1003) sdpar, ratio, pll, pul

            else

              write ( *, 1006)

            end if

          end if

        end if

    end do

    iparmn = iparmx + 1

  end do

  return

 1000 format(1x, i5, 2x, 'ar (factor', i2, ')',4x,i5,6x,3a1,e17.8)
 1001 format ('+', 65x, 'default', 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
subroutine amlst ( iamhd, par, npar, nfac, mspect, n, vcvl, &
  lvcvl, scale, lscale, stpt, lstpt, ifixd, rss, rsd, npardf, &
  npare, idf )

!*****************************************************************************80
!
!! AMLST prints parameter summaries from ARIMA forecasting.
!
!  Discussion:
!
!    This routine prints the parameter summary output from the
!    ARIMA forecasting subroutines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iamhd
!        the indicator value used to designate the type of list
!        to be generated
!        if iamhd=1, the list is for the initial summary of the
!                    estimation routines.
!        if iamhd=2, the list is for the initial report of the
!                    forecasting routines.
!        if iamhd=3, the list is for the final report of the
!                    estimation routines.
!     integer idf
!        the degrees of freedom in the fit.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i)==0, then par(i) will be optimized.
!     integer iparmn
!        the smallest parameter index included in this term.
!     integer iparmx
!        the largest parameter index included in this term.
!     integer lscale
!        the dimension of vector scale.
!     integer lstpt
!        the dimension of vector stpt.
!     integer lvcvl
!        the dimension of vector vcvl.
!     integer mspect(nfac,4)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer npardf
!        the order of the expanded difference filter.
!     integer nfac
!        the number of factors in the model
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     real par(npar)
!        the current estimates of the parameters.
!     real rsd
!        the residual standard deviation.
!     real rss
!        the residual sum of squares.
!     real scale(lscale)
!        the typical size of the parameters.
!     real stpt(lstpt)
!        the step size array.
!     real t975
!        the value of the 97.5 percent point function for the
!        t distribution.
!     real vcvl(lvcvl)
!        the lower half of the variance-covariance matrix, stored
!        row wise.
!
  implicit none

  real &
     rsd,rss
  integer &
     iamhd,idf,lscale,lstpt,lvcvl,n,nfac,npar,npardf,npare
!
!  array arguments
  real &
     par(*),scale(*),stpt(*),vcvl(*)
  integer &
     ifixd(*),mspect(nfac,4)

  real t975
  integer &
     iparmn,iparmx,lbltyp
!
!  external functions
  real &
     ppft
  external ppft
!
!  print heading for information about parameters
!
  write ( *, 1001)

  if (iamhd == 1) then
    write ( *, 1004)
  else if (iamhd == 2) then
    write ( *, 1005)
  else if (iamhd == 3) then
    write ( *, 1006)
  end if

  write ( *, 1001)
!
!  print model summary information
!
  iparmn = 1
  iparmx = 0
  t975 = ppft(0.95e0, n-npar)
!
!  print autoregressive terms
!
  lbltyp = 1
  call amlst1 (iamhd, par, npar, mspect, nfac, vcvl, lvcvl, &
    scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd )
!
!  print mean or trend term
!
  lbltyp = 2
  call amlst1 (iamhd, par, npar, mspect, 1, vcvl, lvcvl, &
    scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd )
!
!  print moving average terms
!
  lbltyp = 3
  call amlst1 (iamhd, par, npar, mspect, nfac, vcvl, lvcvl, &
    scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd )

  write ( *, 1160) n

  if ( 2 <= iamhd ) then
     write ( *, 1040) rss, rsd, n, npardf, npare, idf
  end if

  return

 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)'//' resid', &
     'ual standard deviation   ', 8x, g15.7/' based on degrees o', &
     'f freedom', 1x, i4, ' - ', i3, ' - ', i3, ' = ', i4)
 1160 format (//' number of observations', 48x, '(n)', 1x, i5)
end
subroutine aos ( n, lagmax, acov, prho, iar, ospvar, phi, work, &
  aic, ftest, lacov, laic )

!*****************************************************************************80
!
!! AOS computes autoregressive model order selection statistics.
!
!  Discussion:
!
!    This routine computes autoregressive model order selection
!    statistics.  It performs stepwise fitting of autoregressive
!    coefficients by Durbin's method using Akaike's AIC criterion
!    for selecting order.   The routine is modeled after
!    subroutine UFPE written by Dick Jones.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov), acov0
!        the autocovariances for lags zero to lagmax, and the
!        autocovariance at lag zero.
!     real aic(laic), aicmin
!        the array contaning akiakes criteria for each order, where
!        aic(i+1) is the criteria for order i-1, and the minimum
!        criteria computed.
!     real fplm
!        the floating point largest magnitude.
!     real ftest(2, lagmax)
!        the array in which the f percentage point and probability are
!        stored.
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer j
!        an index variable.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the vector aic.
!     integer n
!        the integer number of observations in each series
!     real ospvar
!        the one step prediction variance for the order selected (iar).
!     real phi(lagmax)
!        the array of autoregressive coefficients for the
!        selected order.
!     real prho(lagmax)
!        the array containing the partial autocorrelation
!        coefficients.
!     real rss, rssmin
!        the one step prediction residual sum of squares and the
!        minimum one step prediction residual sum of squares.
!     real sqpacf
!        the squared value of the partial autocorrelation function at
!        lag i.
!     real work(lagmax)
!        a real work area.
!
  implicit none

  integer lacov
  integer lagmax
  integer laic

  real acov(lacov)
  real acov0
  real aic(laic)
  real aicmin
  external arcoef
  real, external :: cdff
  real fplm
  real ftest(2,lagmax)
  integer i
  integer iar
  integer n
  real ospvar
  real phi(lagmax)
  real prho(lagmax)
  real rss
  real rssmin
  real sqpacf
  real work(lagmax)

  fplm = huge ( fplm )

  rss = acov(1) * real ( n )
  rssmin = rss
  aic(1) = real ( n ) * log ( rss * real ( n + 1 ) / real ( n - 1 ) )
  aicmin = aic(1)
  iar = 0
!
!  Start stepwise procedure.
!
  work(1) = acov(2) / acov(1)
  prho(1) = work(1)
  rss = rss * (1.0e0 - work(1)*work(1))
  aic(2) = real ( n ) * log(rss * real (n+2) / real (n-2))

  sqpacf = work(1) * work(1)
  ftest(1, 1) = fplm
  ftest(2, 1) = 0.0e0

  if ( sqpacf < 1.0e0 ) then

    ftest(1,1) = real (n-2) * sqpacf / (1.0e0 - sqpacf)
    ftest(2,1) = 1.0e0 - cdff(ftest(1,1), 1.0e0, real(n-2))

  end if

  if ( aic(2) < aicmin ) then
    aicmin = aic(2)
    rssmin = rss
    iar = 1
    phi(1) = work(1)
  end if

  acov0 = acov(1)

  do 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 /= n-1 ) then

       aic(i+1) = real ( n ) * log(rss * real (n+i+1) / real (n-i-1))

       sqpacf = work(i) * work(i)

       if ( sqpacf < 1.0e0 ) then

         ftest(1,i) = real (n-i-1) * sqpacf / (1.0e0 - sqpacf)
         ftest(2,i) = 1.0e0 - cdff(ftest(1,i), 1.0e0, real(n-i-1))

       end if

     end if
!
!  if this aic is a minimum and its lag does not exceed n/2,
!  save the coefficients.
!
     if ((aic(i+1) >= aicmin) .or. (i > n/2)) then
       cycle
     end if

     aicmin = aic(i+1)
     rssmin = rss
     iar = i
     phi(1:i) = work(1:i)

  end do
!
!  normalize aic
!
  aic(1) = aic(1) - aicmin
  aic(2:lagmax+1) = aic(2:lagmax+1) - aicmin

  ospvar = rssmin / real (n-iar-1)

  return
end
subroutine aoslst ( prho, aic, ftest, lagmax, laic, iar, phi, &
  ospvar, ifprho, n )

!*****************************************************************************80
!
!! AOSLST lists the autoregressive model order selection statistics.
!
!  Discussion:
!
!    This routine lists the autoregressive model order selection
!    statistics.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real aic(laic)
!        the array containing the akaikes information criterion.
!     character*160 fmt
!        the format used.
!     real ftest(2, lagmax)
!        the array contianing the partial f ratio and its probability
!        of being exceeded.
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive model selected.
!     logical ifprho
!        the logical variable used to indicate if the partial
!        autocorrelations are being printed.  if -ifprho- is
!        .false. the autocorrelationa and their standard errors
!        are printed,  if .true., the partials.
!     integer imax, imin
!        the index values of the first and last observation
!        to be printed per line
!     integer lag
!        the lag value of the autoregressive order selection statistic
!        being printed.
!     integer lagmax
!        the maximum lag at which the autoregressive order selection
!        statistics were computed.
!     integer laic
!        the length of the vector aic.
!     integer m
!        an index variable.
!     integer n
!        the number of observations in the series.
!     integer nperl
!        the number of values to be printed per line.
!     real ospvar
!        the one step prediction variance for the order selected.
!     real phi(lagmax)
!        the autoregressive coefficients for the selected order.
!     real prho(lagmax)
!        the array containing the partial autocorrelation
!        coefficients.
!
  implicit none

  integer iar
  logical ifprho
  integer lagmax
  integer laic
  integer n
  real ospvar
!
!  array arguments
  real &
     aic(laic),ftest(2,*),phi(*),prho(*)

  integer &
     i,imax,imin,lag,m,nperl

  nperl = 12

  do i = 1, lagmax, nperl

    imin = i
    imax = min ( i + nperl - 1, lagmax )

    write ( *, '(a)' ) ' '
    write ( *, '(a, 12(i7))' ) ' lag               ', (lag, lag = imin, imax)

    if (ifprho) then
      write ( *, 1001) (prho(lag), lag = imin, imax)
    end if

    if ( imax == lagmax .and. lagmax == n-1 ) then

      write ( *, '(a19,12(f7.2))' ) ' aic               ', aic(imin+1:imax)
      write ( *, '(a19,12(f7.2))' ) ' f ratio           ', ftest(1,imin:imax-1)
      write ( *, '(a19,12(f7.2))' ) ' f probability     ', ftest(2,imin:imax-1)

    else

      write ( *, '(a19,12(f7.2))') ' aic               ', aic(imin+1:imax+1)
      write ( *, '(a19,12(f7.2))') ' f ratio           ', ftest(1,imin:imax)
      write ( *, '(a19,12(f7.2))') ' f probability     ', ftest(2,imin:imax)

    end if

  end do

  if ( lagmax == n-1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'This value cannot be computed because LAG = N-1.'
  end if
!
!  Print information on order selected
!
  write ( *, '(a,i8)' ) &
    ' order autoregressive process selected =         ', iar
  write ( *, '(a,g14.6)' ) &
    ' one step prediction variance of process selected =', ospvar

  if ( iar == 0 ) then
    return
  end if

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) ' Yule-Walker estimates of the coefficients of'
  write ( *, '(a)' ) ' the autoregressive process selected'

  do i = 1, iar, nperl
    imin = i
    imax = min ( i + nperl - 1, iar )
    write ( *, '(a)' ) ' '
    write ( *, '(a,12(i7))' ) ' coefficient number', (m, m = imin, imax)
    write ( *, '(a,12(f7.4))' ) ' coefficient value ', phi(imin:imax)
  end do

  return

 1001 format( ' pacf              ', 12(2x, f5.2))
!1002 format('(a19,',i2,'(f7.2) )')
!1003 format('(a19 )')
!1004 format('(a19,',i2,'(f7.2))')

end
subroutine aov1er ( y, tag, n, igstat, nztags, ng, ldstak, nmsub, &
  index, isaov1, nall0 )

!*****************************************************************************80
!
!! AOV1ER does preliminary checks on input to the one-way family.
!
!  Discussion:
!
!    This routine does preliminary checking for errors in the input
!    parameters of the oneway family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical error
!        set true if the error checking routine found any errors
!     logical head
!        indicates whether heading needs to be printed
!        true - yes, needs to be printed
!        false - no, has been printed
!     integer i
!        *
!     integer ierr
!        if ierr  /=  0, then errors where found in the parameters
!     integer igstat
!        *
!     integer index
!        the starting location in the stach area of the index for
!        the sorted tags.
!     integer isaov1
!        an indicator variable used for the computation of work
!        space.  if isaov1 = 0, the calling routine is aov1s.  if
!        isaov1 = 1, the calling routine is aov1.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldsmin
!        the minimum size allowed for the stack
!     integer ldstak
!        size of stack allocated in the users main program
!     character*1 ligsta(8), llds(8), ln(8), lng(8), ltag(8),
!    *   ltwo(8), lzero(8)
!        the array(s) containing the name(s) of the variable(s) checked
!        errors
!     integer n
!        the number of observations
!     integer nall0
!        output parameter.  number of stack allocations after
!        stack is initialized.
!     character*1 nmsub(6)
!        name of the calling subroutine
!     integer nv
!        the number of values less than or equal to zero.
!     integer nztags
!        the number of positive non-zero tags, to be determined by
!        this routine
!     real tag(n)
!        the vector of tags.
!     real y(n)
!        the vector of observations.
!
  implicit none

  integer &
     igstat,index,isaov1,ldstak,n,nall0,ng,nztags
!
!  array arguments
  real &
     tag(*),y(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     i,j,ldsmin,nv
  logical &
     error,head
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))

  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', ' ', ' ', ' ', ' '/

  ierr = 0
  head = .true.
!
!  Is number of observations less than 2?
!
  call eisge(nmsub, ln, n, 2, 2, head, error, ltwo)

  if ( error ) then
    ierr = 1
    return
  end if
!
!  Is number of non-zero tags less than 2?
!
  call ervgt(nmsub, ltag, tag, n, 0.0e0, (n-2), head, 7, nv, error, &
     lzero)

  if (error) then
    ierr = 1
    return
  end if

  nztags = n - nv
!
!  Stack must be large enough for a vector of length n to continue
!
  call ldscmp(1, 0, n, 0, 0, 0, 's', 0, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error, llds)

  if (error) then
    ierr = 1
    return
  end if
!
!  Initialize stack and nall0
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  index = stkget(n,2)
!
!  sort tag vector carrying along index to original order and the
!  vector of observations
!
  call geni(istak(index), n, 1, 1)
  call srtirr(istak(index), y, n, tag)
!
!  Count the number of different tag values.
!
  j = n - nztags + 2
  ng = 1
  do i=j,n
     if (tag(i) > tag(i-1)) ng = ng + 1
  end do
!
!  less than 2 different tag groups
!
  call eisii(nmsub, lng, ng, 2, nztags-1, 3, head, error, &
    ltwo, ln)

  if (error) then
    call srtrri(tag, y, n, istak(index))
    call stkclr (nall0)
    ierr = 1
    return
  end if
!
!  Check that dimension of statistics matrix is sufficient
!
  call eisge(nmsub, ligsta, igstat, ng, 3, head, error, lng)

  if (error) then
    call srtrri(tag, y, n, istak(index))
    call stkclr (nall0)
    ierr = 1
    return
  end if
!
!  compute and check for sufficient stack
!
  call ldscmp(11, 0, n+nztags, 0, 0, 0, &
            's', isaov1*4*ng+4*ng+nztags, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error, llds)

  if (error) then
    call srtrri(tag, y, n, istak(index))
    call stkclr (nall0)
    ierr = 1
    return
  end if

  return

 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
subroutine aov1 ( y, tag, n, ldstak )

!*****************************************************************************80
!
!! AOV1 is a user interface to AOV1MN, one-way analysis of variance.
!
!  Discussion:
!
!    This routine -
!    1. calls other routines to check the input parameters
!    2. sets up the needed storage locations, and
!    3. calls aov1mn to compute a comprehensive set of results for a
!    oneway analysis of variance with automatic printout.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer b10
!        starting location in the stack area for b10
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer dtmean
!        the starting location in the stack area for the means
!        of each group
!     integer dtsd
!        the starting location in the stack area of the
!        standard deviations
!     integer dtsize
!        the starting location in the stack area of the size of the
!        different groups
!     integer gpmax
!        the starting location in the stack area of maximum
!        observation
!     integer gpmin
!        the starting location in the stack area of the minumum
!        observation
!     integer ierr
!        a common variable used as a flag indicating whether there
!        are any errors, if = 0 then no errors
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer index
!        the starting location in the stack array of the index for
!        the sorted tags
!     integer int
!        framework code value for integer numbers
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer itemp
!        starting location in the stack for the
!        temporary storage array
!     integer ldstak
!        size of the stack area allocated in the users main program
!     integer n
!        the number of observations to be analyzed
!     integer nall0
!        the number of allocations outstanding at the time that this
!        routine was called.
!     integer ng
!        the number of groups with different positive tag values
!     character*1 nmsub(6)
!        subroutine name
!     integer nprt
!        the variable controlling automatic printout
!        if =0, printout is supressed
!        otherwise printout is provided
!     integer nztags
!        the number of observations with positive non-zero wieghts
!     integer ranks
!        the starting location in work area for the ranks of y
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer srank
!        the starting location in stack for the sum of ranks
!     real tag(n)
!        the vector of tag values
!     integer tval
!        the starting location in the stack for the vector of
!        the different positive tag values, for aov1
!     real y(n)
!        the vector of observations
!
  implicit none

  integer &
     ldstak,n
!
!  array arguments
  real &
     tag(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     b10,dtmean,dtsd,dtsize,gpmax,gpmin,ifp,index,int, &
     itemp,nall0,ng,nprt,nztags,ranks,srank,tval
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget
  external stkget
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))

  data   nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
       /      'a',      'o',      'v',      '1',      ' ',      ' '/

!
!  Set up framework variables for number types
!
  int = 2
  ifp = 3
!
!  Check for errors in parameters, initialize stack, and set nall0.
!
  call aov1er(y, tag, n, n, nztags, ng, ldstak, nmsub, index, 1, &
     nall0)
!
!  Print correct form of call statement and return to caller
!
  if (ierr /= 0 ) then
    ierr = 1
    return
  end if
!
!  print heading
!
   call aov1hd ( )
!
!  Set up additional work vectors for aov1mn as called from aov1
!
  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)

  nprt = 1

  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)
!
!  Release the stack area
!
  call stkclr(nall0)

  return
end
subroutine aov1hd ( )

!*****************************************************************************80
!
!! AOV1HD prints headers for the one-way ANOVA family.
!
!  Discussion:
!
!    A subroutine to print out the heading for the one-way ANOVA
!    family, and is the only source for headings in that family.
!
!  Modified:
!
!    02 December 2006 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!    None
!
  implicit none

  call versp ( .true. )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '                                                Analysis of Variance'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) ' '

  return
end
subroutine aov1mn ( y, tag, n, tvalue, tsize, tmean, tsd, nprt, &
  index, srank, gpmin, gpmax, b10, ranks, itemp, ng, nzw )

!*****************************************************************************80
!
!! AOV1MN computes results for analysis of a one-way classification.
!
!  Discussion:
!
!    This routine computes a comprehensive set of results for
!    analysis of a one-way classification with optional printed output.
!    tag values can be any value where all measurements with tag
!    values less than or equal to zero are excluded from analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, David Hogben,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real af
!        a for f
!     real bf
!        bartlett f
!     real bfrat
!        between groups f ratio
!     real bfsig
!        between groups significance level
!     character*1 blank
!        hollerith blank
!     real bms
!        between ms
!     real bss
!        between ss
!     real c
!        intermediate result storage
!     real cc
!        cochrans c
!     real cfkw
!        correction factor for kruskal-wallis
!     real df
!        d.f.
!     real dfrat
!        deviations about line f ratio
!     real dfsig
!        deviations about line f significance level
!     real dms
!        deviations about line ms
!     real dss
!        deviations about line ss
!     real f
!        between means f-test
!     real fmlc
!        fixed model lower confidence limit for mean
!     real fmuc
!        fixed model upper confidence limit for mean
!     real fnzw
!        *
!     real fplm
!        largest single precision magnitude of machine
!     real fstat
!        f statistic associated with kruskal-wallis h statistic
!     real f1kw
!        f1 d.f. for kruskal-wallis f
!     real f2kw
!        f2 d.f. for kruskal-wallis f
!     real gm
!        grand mean, mean of all observations with positive
!        non-zero tags
!     real gpmax(ng)
!        the vector of maximum observations for each group
!     real gpmin(ng)
!        the vector of minimum observations for each group
!     real gr
!        nzw-ng
!     real g1
!        ng-1
!     character*1 high
!        hollerith + (plus)
!     real hstat
!        kruskal-wallis h statistic, see brownlee(1965), page 256
!     integer i
!        index variable
!     real ibar
!        i bar, ((sum of i)/nzw), where i=1,nzw
!     integer index(n)
!        permutation vector for y and later for tmean
!     character*1 isd
!        can contain following characters for printing
!        +, -,  (blank)
!     integer isz
!        integer size of group
!     integer itemp(nzw)
!        temporary index vector used in computing ranks
!     integer j
!        an index variable
!     integer k
!        index variable
!     integer kk
!        pointer to the largest of the group means
!     integer kkk
!        pointer to the smallest of the group means
!     real k0
!        = nzw - (snc/nzw)/ g1
!     integer l
!        index variable
!     character*1 low
!        hollerith - (minus)
!     integer m
!        index variable
!     character*1 mean
!        can contain following characters for printing
!        +, -,  (blank)
!     real mf
!        m for f
!     real mkw
!        m for kruskal-wallis mean
!     integer m28
!        used in creating backward loop
!     integer m3
!        ng - 2
!     integer m5
!        nzw - 1
!     integer n
!        the number of observations
!     integer ng
!        the number of groups of different positive tag values
!     integer nn
!        aid in printing values
!     integer nne1
!        number of groups with size not equal to one
!     integer nprt
!        the varaible controlling automatic printout
!        if nprt = 0, printout suppressed
!           otherwise printout provided
!     integer nzpntr
!        a pointer to the first non-zero tag in the sorted tag vector
!     integer nzw
!        the number of observations with positive, non-zero, tag values
!     real q
!        significance level from f-distribution
!     real ranks(nzw)
!        the ranks of the observations with positive tag values
!     real ressq
!        residuals squared
!     real rmlc
!        random model lower confidence limit for mean
!     real rmuc
!        random model upper confidence limit for mean
!     real rx
!        used in calculating mandel approximation
!     real sbms
!        sqrt between ms
!     real sc
!        sum of n(i) cubed, where n(i) is the size of group i
!     real sfrat
!        slope f ratio
!     real sfsig
!        slope f significance level
!     real sigkw
!        significance level for kruskal-wallis f (or h)
!     real slbf
!        significance level for barlett f
!     real slcc
!        significance level for cochrans c
!     real smax
!        maximum of s(i), where s(i) is the std. dev. of group i
!     real smin
!        minimum of s(i)
!     real sms
!        slope ms
!     real snc
!        sum of n(i) squared
!     real sos
!        sum of s(i) squared
!     real sqb
!        sqrt between ms / nzw
!     real sqms
!        sqrt within ms / nzw
!     real sqom
!        omega hat squared
!     real sqt
!        sqrt total ms / nzw
!     real srank(ng)
!        the sum of the ranks for the observations in each group
!     real ssf
!        s * sqrt(ng-1) * f
!     real sss
!        slope ss
!     real stats(15)
!        vector of statistics
!     real stms
!        sqrt total ms
!     real sum
!        intermidiate value
!     real swms
!        sqrt within ms
!     real tag(n)
!        vector of classification values - values less than or equal
!        to zero are ignored for analysis.  on entering tag is
!        sorted smallest to largest
!     real tmean(ng)
!        the mean of each of the groups
!     real tms
!        total ms
!     real tsd(ng)
!        the standard deviations of each of the groups (not the
!        standard deviations of the means)
!     real tsize(ng)
!        the size of each of the different groups
!     real tss
!        total ss
!     real tvalue(ng)
!        the different positive (non-zero) tag values analyzed, ordered
!        from smallest to largest
!     real t1
!        t(.05,ng-1)
!     real t2
!        t(.05,ng-1)
!     real t3
!        t(.05,nzw-1)
!     real umlc
!        ungrouped model lower confidence limit for mean
!     real umuc
!        ungrouped model upper confidence limit for mean
!     real u1, u2
!        used in calculating mandel approximation
!     real vkw
!        u for kruskal-wallis f
!     real vls
!        largest variance / smallest variance
!     real v1, v2
!        used in calculating mandel approximation
!     real wms
!        within ms
!     real wss
!        within ss
!     real y(n)
!        observations to be analyzed, sorted by tags
!        y(nzpntr) is the first element with a non-zero tag
!     real ybmax
!        maximum ybar(i), where ybar(i) is the mean of group i
!     real ybmin
!        minimun ybar(i)
!     real ymax
!        maximum observation
!     real ymin
!        minimum observation
!
  implicit none

  integer &
     n,ng,nprt,nzw
!
!  array arguments
  real &
     b10(*),gpmax(*),gpmin(*),ranks(*),srank(*),tag(*),tmean(*), &
     tsd(*),tsize(*),tvalue(*),y(*)
  integer &
     index(*),itemp(*)
!
!
  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,isz,j,k,kk,kkk,l,m,m28,m3,m5,nn,nne1,nzpntr
  character &
     blank*1,high*1,isd*1,low*1,mean*1
!
!  local arrays
  real &
     stats(15)
!
!  external functions
  real &
     cdff,ppff,ppft
  external cdff,ppff,ppft
!
!     machine dependent variable - fplm
!
  data blank /' '/
  data low /'-'/
  data high /'+'/

  fplm = huge ( fplm )
  nzpntr = n - nzw + 1
  fnzw = real ( nzw )
!
!  Zero work vectors.
!
  tvalue(1:ng) = 0.0e0
  tsize(1:ng) = 0.0e0
  tmean(1:ng) = 0.0e0
  tsd(1:ng) = 0.0e0
  srank(1:ng) = 0.0e0
  gpmin(1:ng) = 0.0e0
  gpmax(1:ng) = 0.0e0
  b10(1:ng) = 0.0e0
  stats(1:15) = 0.0e0
  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
!
!  Compute ranks
!
  call ranko(nzw, y(nzpntr), itemp, ranks, ties)
!
!  Initialize first element before entering loop
!
  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
!
!  Determine means and maxs, do summation prior to determining means.
!  J is the group number.
!
  j = 1
  l = nzpntr + 1

  do i=l,n
!
!  New tag group
!
     if ( tag(i) /= tag(i-1) ) then

       j = j + 1
       tvalue(j) = tag(i)
       gpmin(j) = y(i)
       gpmax(j) = y(i)

     end if

     tsize(j) = tsize(j) + 1.0e0
     tmean(j) = tmean(j) + y(i)
     gm = gm + y(i)
!
!  Unnecessary computations if printed output is supressed
!
     if ( nprt /= 0 ) then
       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 + real ( j )
     end if

  end do
!
!  Calculate means
!
  gm = gm / fnzw
  ibar = ibar / fnzw
  k = nzpntr-1
  i = nzpntr

  do j=1,ng

     if (tsize(j) >= 2.0e0) then
        tmean(j) = tmean(j)/tsize(j)
     else
        tmean(j) = tmean(j)
     end if

     k = k + int(tsize(j))
!
!  L gives index to y value within group j
!
     do l=i,k
        ressq = (y(l)-tmean(j))*(y(l)-tmean(j))
        tsd(j) = tsd(j) + ressq
        if ( nprt /= 0 ) then
          bss = bss + (tmean(j)-gm)*(tmean(j)-gm)
          wss = wss + ressq
          tss = tss + (y(l)-gm)*(y(l)-gm)
        end if
     end do

     i = k + 1

  end do
!
!  Now done with tag vector, return vector to input order
!  index is freed for use in other places
!
  call srtrri(tag, y, n, index)
!
!  check for printed output
!
!  Compute standard deviations within each group
!
  if ( nprt == 0 ) then

    do j=1,ng
      tsd(j) = sqrt(tsd(j))
      if ( 1.0 < tsize(j) ) then
        tsd(j) = tsd(j)/sqrt(tsize(j)-1.0e0)
      end if
    end do

    return

  end if
!
!  computations complete for stored output - return if printed
!  output is supressed
!
  ybmin = tmean(1)
  ybmax = tmean(1)
  smin = fplm
!
!  here i is the group number
!
  do i = 1, ng

     if (tsd(i) > 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) > 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)) >= 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)* ( real ( i ) - ibar ) * (tmean(i)-gm)
     stats(4) = stats(4) + tsize(i) &
       * ( real ( i ) - ibar ) * ( real ( i ) - ibar )
!
!  look for smallest and largest means (ybar)
!
     ybmin = min(ybmin,tmean(i))
     ybmax = max(ybmax,tmean(i))

     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)

  end do

  if (stats(2) /= 0.0e0) stats(1) = stats(1)/stats(2)
  if (stats(4) /= 0.0e0) sss = sss*sss/stats(4)
  dss = bss - sss
!
!  degrees of freedom for anova
!
  g1 = real ( ng-1 )
  m3 = ng - 2
  gr = real ( nzw-ng )
  m5 = nzw - 1
!
!  mean squares
!
  bms = bss/g1
  sms = sss
  if (ng >= 3) dms = dss / real ( m3 )
  wms = wss/gr
  tms = tss / real ( m5 )

  if (wms==bms) then
     bfrat = 1.0e0
     bfsig = 1.0e0
  else if (wms==0.0e0) then
     bfrat = fplm
     bfsig = 0.0e0
  else
     bfrat = bms/wms
     bfsig = 1.0e0 - cdff(bfrat,g1,gr)
  end if

  if (wms==dms) then
     dfrat = 1.0e0
     dfsig = 1.0e0
  else if (wms==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==dss+wss) then
     sfrat = 1.0e0
     sfsig = 1.0e0
  else if (dss+wss==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
!
!  compute for kruskal-wallis test
!  for formulae with clearer form and names see
!  kraft and van eeden  a non parametric introduction to statistics,
!  pp. 238 - 240
!
  stats(6) = real ( nzw*(nzw+1) )
  hstat = (12.0e0*hstat/stats(6)) - (3.0e0*real (nzw+1))
  if (ties== real ( nzw*nzw*nzw-nzw ) ) then
     cfkw = 0.0e0
     hstat = 0.0e0
     mkw = 0.0e0
  else
     cfkw = 1.0e0 - ties/real (nzw*nzw*nzw-nzw)
     hstat = hstat/cfkw
     mkw = ((real ( nzw*nzw*nzw ) -sc)/stats(6))/cfkw
  end if

  vkw = 2.0e0*g1 - &
     (0.4e0* real ( 3*ng*m3+nzw*(2*ng*(ng-3)+1)) ) /stats(6) &
     - 6.0e0*sum/5.0e0

  if (mkw-hstat > 0.0e0 .and. &
      mkw /= 0.0e0 .and. vkw /= 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
!
!  compute total statistics
!
  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

  ssf = swms*sqrt(g1*ppff(0.95e0,int(g1),int(gr)))
!
!  tests for homogeneity of variances
!
  if (smax*smax==sos) then
     cc = 1.0e0
  else if (sos /= 0.0e0) then
     cc = smax*smax/sos
  end if
  stats(7) = anint(fnzw/real ( ng ) )

  if ((nne1 >= 2) .and. (cc /= 1.0e0)) then
     slcc = 1.0e0 - &
            cdff ( real (nne1-1)*cc/(1.0e0-cc), stats(7), &
            stats(7)*real (nne1-1) )
  else
     slcc = 1.0e0
  end if

  slcc = real (nne1-1) * slcc
  if (slcc > 1.0e0) slcc = 1.0e0

  if (smin==smax) then
     vls = 1.0e0
  else
     if (smin==0.0e0) then
        vls = fplm
     else
        vls = (smax/smin)*(smax/smin)
     end if
  end if

  if (wms > 0.0e0) mf = gr*log(wms) - mf
  af = (stats(3)-(1.0e0/gr))/(3.0e0*g1)
  slbf = 1.0e0
  if ((af /= 1.0e0) .and. (nne1 >= 2)) then
     df = real (nne1+1) / (af*af)
     bf = (df*mf)/( real ( nne1 - 1 ) * (df/(1.0e0-af+(2.0e0/df))-mf))
     if (bf<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
!
!  computations are now complete.
!
!  print ANOVA
!
  nn = n - nzw
  write ( *,1000) nn
  nn = ng - 1
  write ( *,1010) nn, bss, bms, bfrat, bfsig
  if (ng<3) go to 180
  if (bfsig >= .10) go to 180
  nn = 1
  write ( *,1020) nn, sss, sms, sfrat, sfsig
  write ( *,1030) m3, dss, dms, dfrat, dfsig
  180 nn = nzw - ng
  write ( *,1040) nn, wss, wms
  write ( *,1050) m5, tss
!
!  print kruskal-wallis test
!
  write ( *,1060) hstat, sigkw
!
!  print estimates
!
  write ( *,1070)

  do i=1,ng

     mean = blank
     if (tmean(i) <= ybmin) mean = low
     if (tmean(i) >= ybmax) mean = high
     isd = blank
     if (tsd(i) <= smin) isd = low
     if (tsd(i) >= smax) isd = high
     isz = int(tsize(i))
     if (isz <= 1) then
        write ( *,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 ( *,1080) tvalue(i), isz, tmean(i), mean, tsd(i), &
                          isd, stats(9), gpmin(i), gpmax(i), &
                          srank(i), stats(8), stats(11)
     end if

  end do

  write ( *,1100) nzw, gm, ymin, ymax, swms, sqms, fmlc, fmuc, &
     sbms, sqb, rmlc, rmuc, stms, sqt, umlc, umuc
  if (bfsig<0.10) then
!
!  sort ybar for multiple comparisions of means
!
     call geni(index, ng, 1, 1)
     call srtir(index, ng, tmean)
!
!  compute and print for multiple comparisions
!
     if (nzw-ng<4) go to 270
     write ( *,1110)
!
!  newman-keuls-hartley
!
     write ( *,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 <= m28) go to 260
     if (i==j) go to 230
     stats(14) = abs(tmean(i)-tmean(j))
!
!  mandel approxmation to percent point of studentized range
!
     stats(12) = real ( 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) <= stats(13)) go to 230
     i = i - 1
     go to 220
  230    if (j==1) go to 250
     if (j > m28) go to 240
     write ( *,1150)
     go to 250
  240    write ( *,1160)
  250    write ( *,1140) (tmean(m),m=j,i)
     if (i >= ng) go to 270
     m28 = i
  260    j = j + 1
     go to 210
!
!  scheffe method
!
  270    write ( *,1130)
     j = 1
     m28 = 0
  280    i = ng
  290    if (i <= m28) go to 330
     if (i==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) <= 0.0e0) go to 300
     i = i - 1
     go to 290
  300    if (j==1) go to 320
     if (j > m28) go to 310
     write ( *,1150)
     go to 320
  310    write ( *,1160)
  320    write ( *,1140) (tmean(m),m=j,i)
     if (i >= ng) go to 340
     m28 = i
  330    j = j + 1
     go to 280
!
!  return tag means to original order
!
  340    call srtri(tmean, ng, index)
  end if

  if (nne1 <= 1) return
  write ( *,1170) cc, slcc, bf, slbf, vls

  if (slcc > 0.1e0 .and. slbf > 0.1e0) then
    write ( *, 1190 ) sqom
    return
  end if

  do i=1,ng
     f = f + b10(i)*(tmean(i)-stats(1))*(tmean(i)-stats(1))
     if (stats(2)==0.0e0 .or. tsize(i) <= 1.0e0) then
       exit
     end if
     stats(15) = stats(15) + &
                 (1.0e0-b10(i)*b10(i)/stats(2)/stats(2))/ &
                 (tsize(i)-1.0e0)
  end do

  if ( stats(15) == 0.0e0 ) then
    f = 0.0
  else
    stats(15) = real ( ng*ng-1 ) / (3.0e0*stats(15))
    if ( ng <= 1 ) then
      f = 0.0
    else
      f = (f/g1)/(1.0e0+(2.0e0* real ( m3 ) /(3.0e0*stats(15))))
    end if
  end if

  q = 1.0e0 - cdff(f,g1,anint(stats(15)))
  write ( *,1180) f, q
  write ( *,1190) sqom
  return
!
!  automatic printout is finished
!
 1000 format('group numbers have been assigned according to tag ', &
      /, 'values given, where the smallest tag greater than zero has ', &
      /, 'been assigned ', &
      /, 'group number 1, the next smallest, group number 2, etc.  ', &
      /, 'tags <= zero have not been included in analysis.', &
      /, 'number of values excluded from analysis is ', i4, &
      //,17x, 'source', 14x, 'd.f.', &
     4x, 'sum of squares', 5x, 'mean squares', 9x, 'f ratio', 4x, &
     'f prob.'/)
 1010 format(17x, 'between groups', 5x, i4, 1p2e18.6, 4x, 0pe11.3, &
     f10.3)
 1020 format(20x, 'slope', 14x, i4, 1p2e18.6, 3x, 0pe11.3, f10.3)
 1030 format(20x, 'devs. about line', 3x, i4, 1p2e18.6, 3x, 0pe11.3, &
     f10.3)
 1040 format(17x, 'within groups', 6x, i4, 1p2e18.6)
 1050 format(17x, 'total', 14x, i4, 1pe18.6//)
 1060 format(11x, 'kruskal-wallis rank test for difference between g', &
     'roup means * h =', e11.3, ', f prob =', f6.3, ' (approx.)' &
     /)
 1070 format(55x, 'estimates'/96x, 'sum of'/5x, ' tag ', 10x, 'no.', &
     6x, 'mean', 7x, 'within s.d.', 2x, 's.d. of mean', 5x, &
     'minimum', 7x, 'maximum', 6x, 'ranks', 3x, '95pct conf int f', &
     'or mean'/)
 1080 format(1x, 1pe14.6, i8, e14.5, a1, e13.5, a1, e13.5, 2e14.5, &
     0pf9.1, 1pe13.5, ' to', e12.5)
 1090 format(1x, 1pe14.6, i8, e14.5, a1, 3x, ' estimate not available', &
     ' ', 2e14.5, 0pf9.1, 3x, '********** to **********' )
 1100 format(/11x, 'total', i7, 1pe14.5, 28x, 2e14.5// &
     17x, 'fixed effects model ', 2e14.5, 37x, e13.5, ' to', e12.5/ &
     17x, 'random ', &
     'effects model', 2e14.5, 37x, e13.5, ' to', e12.5/17x, &
     'ungrouped data', 6x, 2e14.5, 37x, e13.5, ' to', e12.5/)
 1110 format(1x, 'pairwise multiple comparison of means.  the means ', &
     'hare put in increasing order in groups separated by *****.  ', &
     'a mean is  '/' adjudged non-significantly different from a', &
     'ny mean in the same group and significantly different at th', &
     'e .05 level from '/' any mean in another group.  ***** ***', &
     '** indicates adjacent groups have no common mean.          ', &
     '                       ')
 1120 format(/3x, 'newman-keuls technique, hartley modification. (ap', &
     'proximate if group numbers are unequal.)')
 1130 format(/3x, 'scheffe technique.')
 1140 format(3x, 9(1pe12.5, ','))
 1150 format(6x, '*****')
 1160 format(3x, '***** *****')
 1170 format(/' tests for homogeneity of variances.'/7x, 'cochrans ', &
     'c = max. variance/sum(variances) = ', f7.4, ', p = ', f6.3, &
     ' (approx.)'/7x, 'bartlett-box f = ', f9.3, ', p = ', &
     f6.3/7x, 'maximum variance / minimum variance = ', f14.4)
 1180 format(7x, 'approx between means f-test in presence of heterog', &
     'eneous variance. f =', f8.3, ', p =', f6.3)
 1190 format(/' model ii - components of variance.'/7x, 'estimate o', &
     'f between component ', 1pe14.6)
end
subroutine aov1s ( y, tag, n, ldstak, nprt, gstat, igstat, ng )

!*****************************************************************************80
!
!! AOV1S is a user interface for AOV1MN, one-way analysis of variance.
!
!  Discussion:
!
!    This routine -
!    1. calls other routines to check the input parameters
!    2. sets up needed storage locations and
!    3. calls aov1mn to compute a comprehensive set of results for a
!       oneway analysis of variance with optional output.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer b10
!        starting location in the stack area for b10
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer gpmax
!        the starting location in the stack area of maximum
!        observation
!     integer gpmin
!        the starting location in the stack area of the minumum
!        observation
!     real gstat(igstat,4)
!        the group statistics.  columns correspond to the tag
!        value, sample size, group mean, and group standard deviation.
!     integer ierr
!        a common variable used as a flag indicating whether there
!        are any errors, if = 0 then no errors
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer igstat
!        the first dimension of gstat.
!     integer index
!        the starting location in the stack array of the index for
!        the sorted tags
!     integer int
!        framework code value for integer numbers
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer itemp
!        starting location in the stack for the
!        temporary storage array
!     integer ldstak
!         size of the stack area allocated in the users main program
!     integer n
!        the number of observations to be analyzed
!     integer nall0
!        the number of allocations outstanding at the time that this
!        routine was called.
!     integer ng
!        the computed number of groups with
!        different positive tag values
!     character*1 nmsub(6)
!        subroutine name
!     integer nprt
!        the variable controlling automatic printout
!        if =0, printout is supressed
!        otherwise printout is provided
!     integer nztags
!        the number of observations with positive non-zero wieghts
!     integer ranks
!        the starting location in stack area for the ranks of y
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer srank
!        the starting location in stack for the sum of ranks
!     real tag(n)
!        the vector of tag values
!     real y(n)
!        the vector of observations
!
  implicit none

  integer &
     igstat,ldstak,n,ng,nprt
!
!  array arguments
  real &
     gstat(*),tag(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     b10,gpmax,gpmin,ifp,index,int,itemp,nall0,nztags, &
     ranks,srank
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget
  external stkget
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
  data   nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
       /      'a',      'o',      'v',      '1',      's',      ' '/
!
!  set up framework variables for number types
!
  int = 2
  ifp = 3
!
!  check for errors in parameters, initialize stack, and set
!  nall0.
!
  call aov1er(y, tag, n, igstat, nztags, ng, ldstak, nmsub, index, &
     0, nall0)
!
!  print correct form of call statement and return to caller
!
  if ( ierr /= 0 ) then
    ierr = 1
    return
  end if
!
!  print heading if desired
!
  if ( nprt /= 0 ) then
    call aov1hd ( )
  end if
!
!  set up additional work vectors for aov1mn as called from aov1s
!
  srank = stkget(ng,ifp)
  gpmin = stkget(ng,ifp)
  gpmax = stkget(ng,ifp)
  b10 = stkget(ng,ifp)
  ranks = stkget(nztags,ifp)
  itemp = stkget(nztags,int)

  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)
!
!  release the stack area
!
  call stkclr(nall0)

  return
end
subroutine aov1xp ( gstat, igstat, ng )

!*****************************************************************************80
!
!! AOV1XP prints storage for one-way family exerciser.
!
!  Discussion:
!
!    Print storage for oneway family exerciser and clear storage vectors
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real gstat(igstat,4)
!        the group statistics.  columns correspond to the tag
!        value, sample size, group mean, and group standard deviation.
!     integer i
!        an index value
!     integer igstat
!        the first dimension of gstat.
!
  implicit none

  integer &
     igstat,ng
!
!  array arguments
  real &
     gstat(igstat,4)
!
!
  integer &
     i,j
!
!  external subroutines
  external setra

  write ( *,1000)
  write ( *,1010) ((gstat(i,j),j=1,4),i=1,ng)
  call setra(gstat, igstat, 4, ng, 0.0e0)

  return

 1000 format(//' storage from aov1   '//6x, 'tagvalue', &
     11x, ' groupsize', 11x, ' groupmean', 13x, ' groupsd'/)
 1010 format(4(1x, g20.14))
end
subroutine arcoef ( acov, phi, rss, lag, lagmax, acov0 )

!*****************************************************************************80
!
!! ARCOEF uses Durbin's method for autoregression coefficients with order lag.
!
!  Discussion:
!
!    This routine uses Durbin's recursive method to compute
!    the autoregressive coefficients of an order LAG process,
!    given on input the coefficients of an order (LAG-1) process.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lagmax)
!        the array of acvf estimates for lags one to lagmax.
!     real acov0
!        the acvf for lag zero.
!     integer j, lag
!        index variables.
!     integer lagmax
!        the maximum lag value used.
!     integer lj, l2
!        index variables.
!     real phi(lagmax)
!        the array of autoregressive coefficients for an ar
!        process of order lag.
!     real rss
!        the one step prediction residual sum of squares.
!     real sum1, sum2
!        variables used in the computations of the autoregressive
!        coefficients.
!     real t
!        a temporary storage location.
!
  implicit none

  real &
     acov0,rss
  integer &
     lag,lagmax
!
!  array arguments
  real &
     acov(lagmax),phi(*)
!
!
  real &
     sum1,sum2,t
  integer &
     j,l1,l2,lj

  l1 = lag - 1
  sum1 = 0.0e0
  sum2 = 0.0e0
  do j = 1, l1
     lj = lag - j
     sum1 = sum1 + phi(j) * acov(lj)
     sum2 = sum2 + phi(j) * acov(j)
  end do

  phi(lag) = (acov(lag) - sum1) / (acov0 - sum2)
  l2 = lag / 2
  do j = 1, l2
     lj = lag - j
     t = phi(j) - phi(lag) * phi(lj)
     phi(lj) = phi(lj) - phi(lag) * phi(j)
     phi(j) = t
  end do

  rss = rss * (1.0e0 - phi(lag)*phi(lag))

  return
end
subroutine arflt ( y, n, iar, phi, yf, nyf )

!*****************************************************************************80
!
!! ARFLT performs autoregressive filtering.
!
!  Discussion:
!
!    This routine performs the autoregressive filtering
!    operation defined by PHI, returning the filtered series in YF.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical err01
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer iar
!        the number of filter coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     character*1 ln(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real phi(iar)
!        the vector containing the filter coefficients.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!     real ymean
!        the mean of the input series y.
!
  implicit none

  integer &
     iar,n,nyf
!
!  array arguments
  real &
     phi(*),y(*),yf(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     ymean
  logical &
     err01,head
!
!  local arrays
  character &
     ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external amean,eisge,fltar
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.
!
!  call error checking routines
!
  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  if ( err01 ) then
    ierr = 1
    return
  end if
!
!  compute arithmetic mean
!
  call amean ( y, n, ymean )

  yf(1:n) = y(1:n) - ymean

  call fltar (yf, n, iar, phi, yf, nyf)

  return
end
subroutine assess ( d, iv, p, step, stlstg, v, x, x0 )

!***********************************************************************
!
!! ASSESS assesses a candidate step.
!
!  Discussion:
!
!    This routine is called by an unconstrained minimization
!    routine to assess the next candidate step.  It may recommend one
!    of several courses of action, such as accepting the step,
!    recomputing it using the same or a new quadratic model, or
!    halting due to convergence or false convergence.  See the return
!    code listing below.
!
!    This routine is called as part of the NL2SOL (nonlinear
!    least-squares) package.  It may be used in any unconstrained
!    minimization solver that uses dogleg, Goldfeld-Quandt-Trotter,
!    or Levenberg-Marquardt steps.
!
!    See Dennis, Gay and Welsch for further discussion of the assessing
!    and model switching strategies.  While NL2SOL considers only two
!    models, ASSESS is designed to handle any number of models.
!
!    On the first call of an iteration, only the I/O variables
!    step, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), and
!    V(PREDUC) need have been initialized.  Between calls, no I/O
!    values execpt STEP, X, IV(MODEL), V(G) and the stopping tolerances
!    should be changed.
!
!    After a return for convergence or false convergence, one can
!    change the stopping tolerances and call ASSESS again, in which
!    case the stopping tests will be repeated.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
!    Michael Powell,
!    A FORTRAN Subroutine for Solving Systems of Nonlinear Algebraic Equations,
!    in Numerical Methods for Nonlinear Algebraic Equations,
!    edited by Philip Rabinowitz,
!    Gordon and Breach, London, 1970.
!
!  Parameters:
!
!     iv (i/o) integer parameter and scratch vector -- see description
!             below of iv values referenced.
!
!    Input, real D(P), a scale vector used in computing V(RELDX).
!
!    Input, integer P, the number of parameters being optimized.
!
!   step (i/o) on input, step is the step to be assessed.  it is un-
!             changed on output unless a previous step achieved a
!             better objective function reduction, in which case stlstg
!             will have been copied to step.
!
! stlstg (i/o) when assess recommends recomputing step even though the
!             current (or a previous) step yields an objective func-
!             tion decrease, it saves in stlstg the step that gave the
!             best function reduction seen so far (in the current itera-
!             tion).  if the recomputed step yields a larger function
!             value, then step is restored from stlstg and
!             x = x0 + step is recomputed.
!
!      v (i/o) real parameter and scratch vector -- see description
!             below of v values referenced.
!
!      x (i/o) on input, x = x0 + step is the point at which the objec-
!             tive function has just been evaluated.  if an earlier
!             step yielded a bigger function decrease, then x is
!             restored to the corresponding earlier value.  otherwise,
!             if the current step does not give any function decrease,
!             then x is restored to x0.
!
!     x0 (in)  initial objective function parameter vector (at the
!             start of the current iteration).
!
!  iv values referenced
!
!    iv(irc) (i/o) on input for the first step tried in a new iteration,
!             iv(irc) should be set to 3 or 4 (the value to which it is
!             set when step is definitely to be accepted).  on input
!             after step has been recomputed, iv(irc) should be
!             unchanged since the previous return of assess.
!                on output, iv(irc) is a return code having one of the
!             following values...
!                  1 = switch models or try smaller step.
!                  2 = switch models or accept step.
!                  3 = accept step and determine v(radfac) by gradient
!                       tests.
!                  4 = accept step, v(radfac) has been determined.
!                  5 = recompute step (using the same model).
!                  6 = recompute step with radius = v(lmax0) but do not
!                       evaulate the objective function.
!                  7 = x-convergence (see v(xctol)).
!                  8 = relative function convergence (see v(rfctol)).
!                  9 = both x- and relative function convergence.
!                 10 = absolute function convergence (see v(afctol)).
!                 11 = singular convergence (see v(lmax0)).
!                 12 = false convergence (see v(xftol)).
!                 13 = iv(irc) was out of range on input.
!             return code i has precdence over i+1 for i = 9, 10, 11.
! iv(mlstgd) (i/o) saved value of iv(model).
!  iv(model) (i/o) on input, iv(model) should be an integer identifying
!             the current quadratic model of the objective function.
!             if a previous step yielded a better function reduction,
!             then iv(model) will be set to iv(mlstgd) on output.
! iv(nfcall) (in)  invocation count for the objective function.
! iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest
!             function reduction this iteration.  iv(nfgcal) remains
!             unchanged until a function reduction is obtained.
! iv(radinc) (i/o) the number of radius increases (or minus the number
!             of decreases) so far this iteration.
! iv(restor) (out) set to 0 unless x and v(f) have been restored, in
!             which case assess sets iv(restor) = 1.
!  iv(stage) (i/o) count of the number of models tried so far in the
!             current iteration.
! iv(stglim) (in)  maximum number of models to consider.
! iv(switch) (out) set to 0 unless a new model is being tried and it
!             gives a smaller function value than the previous model,
!             in which case assess sets iv(switch) = 1.
! iv(toobig) (in)  is nonzero if step was too big (e.g. if it caused
!             overflow).
!   iv(xirc) (i/o) value that iv(irc) would have in the absence of
!             convergence, false convergence, and oversized steps.
!
!  v values referenced
!
! v(afctol) (in)  absolute function convergence tolerance.  if the
!             absolute value of the current function value v(f) is less
!             than v(afctol), then assess returns with iv(irc) = 10.
! v(decfac) (in)  factor by which to decrease radius when iv(toobig) is
!             nonzero.
! v(dstnrm) (in)  the 2-norm of d * step.
! v(dstsav) (i/o) value of v(dstnrm) on saved step.
!   v(dst0) (in)  the 2-norm of d times the Newton step (when defined,
!             i.e., for 0 <= v(nreduc) ).
!      v(f) (i/o) on both input and output, v(f) is the objective func-
!             tion value at x.  if x is restored to a previous value,
!             then v(f) is restored to the corresponding value.
!   v(fdif) (out) the function reduction v(f0) - v(f) (for the output
!             value of v(f) if an earlier step gave a bigger function
!             decrease, and for the input value of v(f) otherwise).
! v(flstgd) (i/o) saved value of v(f).
!     v(f0) (in)  objective function value at start of iteration.
! v(gtslst) (i/o) value of v(gtstep) on saved step.
! v(gtstep) (in)  inner product between step and gradient.
! v(incfac) (in)  minimum factor by which to increase radius.
!  v(lmax0) (in)  maximum reasonable step size (and initial step bound).
!             if the actual function decrease is no more than twice
!             what was predicted, if a return with iv(irc) = 7, 8, 9,
!             or 10 does not occur, if v(lmax0) < v(dstnrm), and if
!             v(preduc) <= v(rfctol) * abs(v(f0)), then assess re-
!             turns with iv(irc) = 11.  if so doing appears worthwhile,
!             then assess repeats this test with v(preduc) computed for
!             a step of length v(lmax0) (by a return with iv(irc) = 6).
! v(nreduc) (i/o)  function reduction predicted by quadratic model for
!             Newton step.  if assess is called with iv(irc) = 6, i.e.,
!             if v(preduc) has been computed with radius = v(lmax0) for
!             use in the singular convervence test, then v(nreduc) is
!             set to -v(preduc) before the latter is restored.
! v(plstgd) (i/o) value of v(preduc) on saved step.
! v(preduc) (i/o) function reduction predicted by quadratic model for
!             current step.
! v(radfac) (out) factor to be used in determining the new radius,
!             which should be v(radfac)*dst, where  dst  is either the
!             output value of v(dstnrm) or the 2-norm of
!             diag(newd) * step  for the output value of step and the
!             updated version, newd, of the scale vector d.  for
!             iv(irc) = 3, v(radfac) = 1.0 is returned.
! v(rdfcmn) (in)  minimum value for v(radfac) in terms of the input
!             value of v(dstnrm) -- suggested value = 0.1.
! v(rdfcmx) (in)  maximum value for v(radfac) -- suggested value = 4.0.
!  v(reldx) (out) scaled relative change in x caused by step, computed
!             by function  reldst  as
!                 max (d(i)*abs(x(i)-x0(i)), 1 <= i <= p) /
!                    max (d(i)*(abs(x(i))+abs(x0(i))), 1 <= i <= p).
!             if an acceptable step is returned, then v(reldx) is com-
!             puted using the output (possibly restored) values of x
!             and step.  otherwise it is computed using the input
!             values.
! v(rfctol) (in)  relative function convergence tolerance.  if the
!             actual function reduction is at most twice what was pre-
!             dicted and  v(nreduc) <= v(rfctol)*abs(v(f0)),  then
!             assess returns with iv(irc) = 8 or 9.  see also v(lmax0).
! v(STPPAR) (in)  Marquardt parameter -- 0 means full Newton step.
! v(tuner1) (in)  tuning constant used to decide if the function
!             reduction was much less than expected.  suggested
!             value = 0.1.
! v(tuner2) (in)  tuning constant used to decide if the function
!             reduction was large enough to accept step.  suggested
!             value = 10**-4.
! v(tuner3) (in)  tuning constant used to decide if the radius
!             should be increased.  suggested value = 0.75.
!  v(xctol) (in)  x-convergence criterion.  if step is a Newton step
!             (v(STPPAR) = 0) having v(reldx) <= v(xctol) and giving
!             at most twice the predicted function decrease, then
!             assess returns iv(irc) = 7 or 9.
!  v(xftol) (in)  false convergence tolerance.  if step gave no or only
!             a small function decrease and v(reldx) <= v(xftol),
!             then assess returns with iv(irc) = 12.
!
  implicit none

  integer p

  integer, parameter :: afctol = 31
  real d(p)
  integer, parameter :: decfac = 22
  real emax
  logical goodx
  real gts
  integer i
  integer, parameter :: irc = 3
  integer iv(13)
  integer, parameter :: lmax0 = 35
  integer nfc
  integer, parameter :: nreduc = 6
  integer, parameter :: plstgd = 15
  integer, parameter :: preduc = 7
  integer, parameter :: radfac = 16
  integer, parameter :: rdfcmn = 24
  integer, parameter :: rdfcmx = 25
  real reldst
  integer, parameter :: reldx = 17
  real reldx1
  real rfac1
  integer, parameter :: rfctol = 32
  real step(p)
  real stlstg(p)
  integer, parameter :: stppar = 5
  integer, parameter :: tuner1 = 26
  integer, parameter :: tuner2 = 27
  integer, parameter :: tuner3 = 28
  real v(35)
  real x(p)
  real x0(p)
  integer, parameter :: xctol = 33
  integer, parameter :: xftol = 34
  integer, parameter :: xirc = 13
  real xmax
!
!  subscripts for iv and v
!
      integer dstnrm, dstsav, dst0, f, fdif, flstgd, f0
      integer gtslst, gtstep, incfac, mlstgd, model, nfcall, &
              nfgcal, radinc, &
              restor, stage, stglim, &
              switch, toobig
     parameter ( mlstgd=4, model=5, nfcall=6 )
     parameter ( nfgcal=7, radinc=8, restor=9, stage=10 )
     parameter ( stglim=11, switch=12, toobig=2 )
     parameter ( dstnrm=2, dst0=3 )
     parameter ( dstsav=18, f=10, fdif=11, flstgd=12, f0=13 )
     parameter ( gtslst=14, gtstep=4, incfac=23 )

  nfc = iv(nfcall)
  iv(switch) = 0
  iv(restor) = 0
  rfac1 = 1.0E+00
  goodx = .true.
  i = iv(irc)

  if ( i < 1 .or. 12 < i ) then
    iv(irc) = 13
    return
  end if

  go to (20,30,10,10,40,360,290,290,290,290,290,140), i
!
!  Initialize for new iteration.
!
 10   continue

      iv(stage) = 1
      iv(radinc) = 0
      v(flstgd) = v(f0)

      if ( iv(toobig) /= 0 ) then
         iv(stage) = -1
         iv(xirc) = i
         v(radfac) = v(decfac)
         iv(radinc) = iv(radinc) - 1
         iv(irc) = 5
         return
       end if

       go to 90
!
!  Step was recomputed with new model or smaller radius.
!  First decide which.
!
 20   continue
!
!  Old model retained, smaller radius tried.
!  Do not consider any more new models this iteration.
!
      if ( iv(model) == iv(mlstgd) ) then
         iv(stage) = iv(stglim)
         iv(radinc) = -1
         go to 90
      end if
!
!  A new model is being tried.  Decide whether to keep it.
!
 30   iv(stage) = iv(stage) + 1
!
!  Now we add the possibiltiy that step was recomputed with
!  the same model, perhaps because of an oversized step.
!
 40   if ( 0 < iv(stage) ) then
        go to 50
      end if
!
!  Step was recomputed because it was too big.
!
         if (iv(toobig) /= 0) then
           v(radfac) = v(decfac)
           iv(radinc) = iv(radinc) - 1
           iv(irc) = 5
           return
         end if
!
!  Restore IV(STAGE) and pick up where we left off.
!
         iv(stage) = -iv(stage)
         i = iv(xirc)
         go to (20, 30, 90, 90, 70), i

 50   if (iv(toobig) == 0) then
        go to 70
      end if
!
!  Handle oversize step.
!
      if ( iv(radinc) <= 0 ) then
         iv(stage) = -iv(stage)
         iv(xirc) = iv(irc)
         v(radfac) = v(decfac)
         iv(radinc) = iv(radinc) - 1
         iv(irc) = 5
         return
      end if

      go to 80

 70   if (v(f) < v(flstgd)) then
        go to 90
      end if
!
!  The new step is a loser.  Restore old model.
!
      if ( iv(model) /= iv(mlstgd) ) then
        iv(model) = iv(mlstgd)
        iv(switch) = 1
      end if
!
!  Restore step, etc. only if a previous step decreased V(F).
!
 80   continue

      if ( v(flstgd) < v(f0) ) then
        iv(restor) = 1
        v(f) = v(flstgd)
        v(preduc) = v(plstgd)
        v(gtstep) = v(gtslst)
        if (iv(switch) == 0) rfac1 = v(dstnrm) / v(dstsav)
        v(dstnrm) = v(dstsav)
        nfc = iv(nfgcal)
        goodx = .false.
      end if
!
!  Compute relative change in X by current step.
!
 90   continue

      reldx1 = reldst ( p, d, x, x0 )
!
!  Restore X and STEP if necessary.
!
      if ( .not. goodx ) then

        step(1:p) = stlstg(1:p)
        x(1:p) = x0(1:p) + stlstg(1:p)

      end if

      v(fdif) = v(f0) - v(f)
!
!  No (or only a trivial) function decrease,
!  so try new model or smaller radius.
!
      if ( v(fdif) <= v(tuner2) * v(preduc) ) then

         v(reldx) = reldx1

         if ( v(f0) <= v(f) ) then
           iv(mlstgd) = iv(model)
           v(flstgd) = v(f)
           v(f) = v(f0)
           x(1:p) = x0(1:p)
           iv(restor) = 1
         else
           iv(nfgcal) = nfc
         end if

         iv(irc) = 1

         if ( iv(stglim) <= iv(stage) ) then
           iv(irc) = 5
           iv(radinc) = iv(radinc) - 1
         end if

      else
!
!  Nontrivial function decrease achieved.
!
      iv(nfgcal) = nfc
      rfac1 = 1.0E+00
      if ( goodx ) then
        v(reldx) = reldx1
      end if
      v(dstsav) = v(dstnrm)

      if ( v(preduc) * v(tuner1) < v(fdif) ) then
        go to 200
      end if
!
!  Decrease was much less than predicted: either change models
!  or accept step with decreased radius.
!
      if ( iv(stage) < iv(stglim) ) then
        iv(irc) = 2
      else
        iv(irc) = 4
      end if

    end if
!
!  Set V(RADFAC) to Fletcher's decrease factor.
!
      iv(xirc) = iv(irc)
      emax = v(gtstep) + v(fdif)
      v(radfac) = 0.5E+00 * rfac1

      if (emax < v(gtstep) ) then
        v(radfac) = rfac1 * max ( v(rdfcmn), 0.5E+00 * v(gtstep) / emax )
      end if
!
!  Do a false convergence test.
!
 140  continue

      if ( v(reldx) <= v(xftol)) then
        go to 160
      end if

      iv(irc) = iv(xirc)

      if (v(f) < v(f0)) then
        go to 230
      end if

      go to 300

 160  iv(irc) = 12
      go to 310
!
!  Handle good function decrease,
!
 200  if (v(fdif) < (-v(tuner3) * v(gtstep))) then
        go to 260
      end if
!
!  Increasing radius looks worthwhile.  See if we just
!  recomputed step with a decreased radius or restored step
!  after recomputing it with a larger radius.
!
      if (iv(radinc) < 0) then
        go to 260
      end if

      if (iv(restor) == 1) then
        go to 260
      end if
!
!  We did not.  Try a longer step unless this was a Newton step.
!
         v(radfac) = v(rdfcmx)
         gts = v(gtstep)
         if ( v(fdif) < ( 0.5E+00 / v(radfac) - 1.0E+00) * gts ) then
           v(radfac) = max ( v(incfac), 0.5E+00 * gts / ( gts + v(fdif) ) )
         end if
         iv(irc) = 4

         if ( v(stppar) == 0.0E+00 ) then
           go to 300
         end if
!
!  Step was not a Newton step.  Recompute it with a larger radius.
!
              iv(irc) = 5
              iv(radinc) = iv(radinc) + 1
!
!  Save values corresponding to good step.
!
 230  v(flstgd) = v(f)
      iv(mlstgd) = iv(model)
      stlstg(1:p) = step(1:p)
      v(dstsav) = v(dstnrm)
      iv(nfgcal) = nfc
      v(plstgd) = v(preduc)
      v(gtslst) = v(gtstep)
      go to 300
!
!  Accept step with radius unchanged.
!
 260  v(radfac) = 1.0E+00
      iv(irc) = 3
      go to 300
!
!  Come here for a restart after convergence.
!
 290  iv(irc) = iv(xirc)

      if ( v(dstsav) < 0.0E+00 ) then
        iv(irc) = 12
      end if
      go to 310
!
!  Perform convergence tests.
!
 300  iv(xirc) = iv(irc)

 310  continue

      if ( abs ( v(f) ) < v(afctol) ) then
        iv(irc) = 10
      end if

      if ( v(preduc) < 0.5E+00 * v(fdif) ) then
        return
      end if

      emax = v(rfctol) * abs(v(f0))

      if ( v(lmax0) < v(dstnrm) .and. v(preduc) <= emax ) then
        iv(irc) = 11
      end if

      if ( 0.0E+00 <= v(dst0) ) then

        if (( 0.0E+00 < v(nreduc) .and. v(nreduc) <= emax) .or. &
            (v(nreduc) == 0.0E+00 .and. v(preduc) == 0.0))  then
          i = 2
        else
          i = 0
        end if

        if ( v(stppar) == 0.0E+00 .and. &
             v(reldx) <= v(xctol) .and. &
             goodx ) then
          i = i + 1
        end if

        if ( 0 < i ) then
          iv(irc) = i + 6
        end if

      end if
!
!  Consider recomputing step of length V(LMAX0) for singular
!  convergence test.
!
      if ( 2 < abs ( iv(irc) -3 ) .and. iv(irc) /= 12 ) then
        return
      end if

      if ( v(lmax0) < v(dstnrm) ) then

        if ( 0.5E+00 * v(dstnrm) <= v(lmax0) ) then
          return
        end if

        xmax = v(lmax0) / v(dstnrm)

        if ( emax <= xmax * ( 2.0E+00 - xmax) * v(preduc) ) then
          return
        end if

      else

         if ( emax <= v(preduc) ) then
           return
         end if

         if ( 0.0E+00 < v(dst0) ) then

           if ( 0.5E+00 * v(dst0) <= v(lmax0) ) then
             return
           end if

         end if

      end if

  if ( v(nreduc) < 0.0E+00 ) then
    if ( -v(nreduc) <= v(rfctol) * abs ( v(f0) ) ) then
      iv(irc) = 11
    end if
    return
  end if
!
!  Recompute V(PREDUC) for use in singular convergence test.
!
  v(gtslst) = v(gtstep)
  v(dstsav) = v(dstnrm)
  if ( iv(irc) == 12 ) then
    v(dstsav) = -v(dstsav)
  end if
  v(plstgd) = v(preduc)
  iv(irc) = 6
  stlstg(1:p) = step(1:p)
  return
!
!  Perform singular convergence test with recomputed V(PREDUC).
!
 360  continue

  v(gtstep) = v(gtslst)
  v(dstnrm) = abs(v(dstsav))
  step(1:p) = stlstg(1:p)

  if ( v(dstsav) <= 0.0E+00 ) then
    iv(irc) = 12
  else
    iv(irc) = iv(xirc)
  end if

  v(nreduc) = -v(preduc)
  v(preduc) = v(plstgd)

  if ( -v(nreduc) <= v(rfctol) * abs(v(f0)) ) then
    iv(irc) = 11
  end if

  return
end
subroutine axpby ( n, sa, sx, incx, sb, sy, incy, sz, incz )

!*****************************************************************************80
!
!! AXPBY: SZ(1:N) = SA * SX(1:N) + SB * SY(1:N).
!
!  Discussion:
!
!    This routine is adapted from BLAS subroutine saxpy.
!
!    Overwrite real sz with real sa*sx + sb*sy.
!
!    For i = 0 to n-1, replace  sz(lz+i*incz) with sa*sx(lx+i*incx) +
!    sy(ly+i*incy), where lx = 1 if incx  >=  0, else lx = (-incx)*n,
!    and ly and lz are defined in a similar way using incy and incz,
!    respectively.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sa,sb
  integer &
     incx,incy,incz,n
!
!  array arguments
  real &
     sx(*),sy(*),sz(*)

  integer &
     i,ix,iy,iz,m,ns

  if(n <= 0) return
  if ((incx == 1) .and. (incy == 1) .and. (incz == 1)) &
     go to 20
  if ((incx  >=  2) .and. (incx == incy) .and. (incx == incz)) &
     go to 60
!
!  code for nonequal or nonpositive increments.
!
  ix = 1
  iy = 1
  iz = 1
  if(incx<0)ix = (-n+1)*incx + 1
  if(incy<0)iy = (-n+1)*incy + 1
  if(incz<0)iz = (-n+1)*incz + 1
  do i = 1,n
    sz(iz) = sa*sx(ix) + sb*sy(iy)
    ix = ix + incx
    iy = iy + incy
    iz = iz + incz
  end do
  return
!
!  code for both increments equal to 1
!
!  clean-up loop so remaining vector length is a multiple of 4.
!
   20 m = mod(n,4)

  sz(1:m) = sa * sx(1:m) + sb * sy(1:m)

  if( n < 4 ) then
    return
  end if

  do i = m + 1, 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)
  end do
  return
!
!   code for equal, positive, nonunit increments.
!
   60 continue
  ns = n*incx
  do i=1,ns,incx
    sz(i) = sa*sx(i) + sb*sy(i)
  end do

  return
end
subroutine backop ( mspec, nfac, npardf, mbol, mbo, nparma, nparar )

!*****************************************************************************80
!
!! BACKOP computes the number of back order terms for an ARIMA model.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer j
!        an index variable.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     integer mspec(4,nfac)
!        the array containing the values of p, d, q, and s for each fact
!     integer nfac
!        the number of factors in the model
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer nparma
!        the length of the vector parma
!
  implicit none

  integer &
     mbo,mbol,nfac,nparar,npardf,nparma
!
!  array arguments
  integer &
     mspec(4,*)
!
!     compute degree of back operator resulting from the ndf
!     differencing factors (= nd dot iod).
!
  nparar = dot_product ( mspec(1,1:nfac), mspec(4,1:nfac) )
  npardf = dot_product ( mspec(2,1:nfac), mspec(4,1:nfac) )
  nparma = dot_product ( mspec(3,1:nfac), mspec(4,1:nfac) )

  mbol = npardf + nparar
  mbo = max ( mbol, nparma )

  return
end
function betai ( x, pin, qin )

!*****************************************************************************80
!
!! BETAI computes the incomplete Beta ratio.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!  Reference:
!
!    Nancy Bosten, Thomas Aird,
!    Remark on Algorithm 179, 
!    Communications of the ACM,
!    Volume 17, page 153, 1974.
!
!  Parameters:
!
!    x   value to which function is to be integrated. x must be in (0,1).
!
!    p   input (1st) parameter (must be greater than 0)
!
!    q   input (2nd) parameter (must be greater than 0)
!
!    betai  incomplete beta function ratio, the probability that a random
!        variable from a beta distribution having parameters p and q
!        will be less than or equal to x.
!
!
  implicit none

  real betai
  real pin
  real qin
  real x

  real alneps,alnsml,c,eps,fac1,fac2,finsum,p,p1,ps,q,sml,term,xb,y
  integer i,ib,n
!
!  external functions
  real albeta
  external albeta

  data             eps, alneps, sml, alnsml / 4*0.0 /

  if ( eps == 0.0 ) then
    eps = 0.5 * epsilon ( eps )
    alneps = log(eps)
    sml = tiny ( sml )
    alnsml = log(sml)
  end if

  if (x<0. .or. x > 1.0) then
    call xerror ( 'betai   x is not in the range (0,1)', 1, 2)
  end if

  if (pin <= 0. .or. qin <= 0.) then
    call xerror ( 'betai   p and/or q is le zero', 2, 2)
  end if

  y = x
  p = pin
  q = qin

  if ( p < q .or. 0.8 <= x ) then

    if ( 0.2 <= x ) then
      y = 1.0 - y
      p = qin
      q = pin
    end if

  end if

!20 continue

  if ((p+q)*y/(p+1.)<eps) go to 80
!
! evaluate the infinite sum first.
! term will equal y**p/beta(ps,p) * (1.-ps)i * y**i / fac(i)
!
  ps = q - aint(q)
  if (ps==0.) ps = 1.0
  xb = p*log(y) -  albeta(ps, p) - log(p)
  betai = 0.0

  if (xb >= alnsml) then

     betai = exp(xb)
     fac2 = 1.0
     if (ps /= 1.0e0) then
        fac1 = 1.0
        n = int ( max(alneps/log(y), 4.0e0) )

        do i=1,n

           if (( real ( i ) -ps==0.0e0) .or. (fac1==0.0e0)) then
              fac1 = 0.0e0
           else
              if (log(abs(fac1)) + log(abs(real ( i ) -ps)) + log(y) - &
                  log(real(i)) < alnsml) then
                 fac1 = 0.0e0
              else
                 fac1 = fac1 * ( real ( i ) -ps)*y/ real ( i )
              end if
           end if
           fac2 = fac2 + fac1*p/(p+real ( i ) )

       end do

     end if
     betai = betai*fac2
  end if
!
!  now evaluate the finite sum, maybe.
!
  if (q <= 1.0) go to 70

  xb = p*log(y) + q*log(1.0-y) - albeta(p,q) - log(q)
  ib = int ( max (xb/alnsml, 0.0) )
  term = exp (xb - real ( ib ) * alnsml)
  c = 1.0/(1.0-y)
  p1 = q*c/(p+q-1.0)

  finsum = 0.0
  n = int ( q )
  if (q== real ( n ) ) n = n - 1

  do i=1,n

    if (p1 <= 1.0 .and. term/eps <= finsum) go to 60

    if (q-real ( i ) +1.0e0 == 0.0e0) then
      term = 0.0e0
    else
      if (log(abs(q-real ( i )+1.0e0)) + log(abs(c)) + log(abs(term)) - &
          log(abs(p+q-real ( i ))) < alnsml) then
        term = 0.0e0
      else
        term = (q-real ( i ) +1.0e0)*c*term/(p+q-real ( i ) )
      end if
    end if

    if (term > 1.0) then
      ib = ib - 1
      term = term*sml
    end if

    if ( ib==0 ) then
      finsum = finsum + term
    end if

  end do

 60   betai = betai + finsum
 70   continue

  if (y /= x .or. p /= pin) betai = 1.0 - betai
  betai = max (min (betai, 1.0), 0.0)
  return

 80   continue

  betai = 0.0
  xb = p*log(max(y,sml)) - log(p) - albeta(p,q)
  if (xb > alnsml .and. y /= 0.) betai = exp (xb)
  if (y /= x .or. p /= pin) betai = 1.0 - betai

  return
end
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 )

!*****************************************************************************80
!
!! BFSDRV is the driver for time series Fourier spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real bw
!        the bandwidth.
!     real ccov(iccov,jccov,m)
!        the covariances.
!     real ceven(lagmx1)
!        the sums of the covariances for each lag.
!     real codd(lagmx1)
!        the differences of the covariances for each lag.
!     real cspc2(icspc2,nw)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     real df
!        the effective degrees of freedom.
!     real fmax, fmin
!        the maximum and minimum frequences at which the
!        spectrum is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index variable
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer iphas
!        the first dimension of the array phas.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ilog
!        a code used to specify the type of plot, where if
!        ilog = 0 the plot is linear/linear, if
!        ilog = 1 the plot is log/linear, if
!     integer ispcer
!        an error flag used for the spectrum plots.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer i3c
!        statement function for finding locations within ccov.
!     integer i3n
!        statement function for finding locations within nlppc.
!     integer jccov
!        the second dimension of ccov
!     integer jnlppc
!        the second dimension of nlppc
!     integer lag
!        the lag windwo truncation point used for a specific window.
!     integer laglst
!        the last lag before missing data caused an acvf
!        to be unable to be computed.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        the value lagmax+1.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were computed
!     integer n
!        the integer number of observations in each series
!     logical newpg
!        the logical variable used to determine if output
!        will begin on a new page (true) or not (false).
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     integer nfused
!        the number of frequencies actually used.
!     integer nlppc(inlppc,jnlppc,m)
!         the array containing the number of lag product pairs.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer npts
!        the number of x, y coordinates to be plotted.
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     integer nwused
!        the number of different bandwidths actually used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     real phas(iphas,nw)
!        the phase component of the bivariate spectrum.
!     real spcf1(nf), spcf2(nf)
!        the arrays in which the spectrum is stored.
!     logical univar
!        the logical variable used to determine if the output
!        is for univariate (true) or bivariate (false) spectra.
!     real w(lw)
!        the vector of windows.
!     external window
!        the subroutine used to compute the window.
!     real work(lwork)
!        the vector of work space.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plot.
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plots.
!     real ymean1, ymean2
!        the mean of the observed time series
!     real ymiss1, ymiss2
!        the user supplied code which is used to determine whether or
!        not an observation in the series is missing.  if y(i) = ymiss,
!        the value is assumed missing, otherwise it is not.
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!     real y1(n), y2(n)
!         the array containing the observed time series.
!
  implicit none

  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
!
!  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
!
!  subroutine arguments
  external window
!
!  scalars in common
  integer &
     ierr
!
!
  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
!
!  external functions
  integer &
     lstlag
  external lstlag
!
!  external subroutines
  external acvf,acvff,acvfm,bfser,bfslag,bfsmn,ccvf,ccvff,ccvfm, &
     dfbw,dfbwm,setfrq,ufsest,ufsout
!
!  common blocks
  common /errchk/ierr
!
!  statement functions
  integer &
     i3c,i3n
!
!  statement function definitions
!
  i3c(i,j,k) = i + (j-1)*iccov + (k-1)*jccov*iccov
  i3n(i,j,k) = i + (j-1)*inlppc + (k-1)*jnlppc*inlppc

  nfused = nf
  if (option(4)) then
    fmn = max(fmin, 0.0e0)
    fmx = min(fmax, 0.5e0)
    if (fmn >= fmx) then
      fmn = 0.0e0
      fmx = 0.5e0
    end if
  else
!
!  set various values for short forms of call statement
!
    nprt = -1
    fmn = 0.0e0
    fmx = 0.5e0
    lagmx1 = lagmax + 1
  end if
!
!  check for errors
!
  call bfser(nmsub, n, lagmax, iccov, jccov, inlppc, jnlppc, m, &
             index1, index2, icspc2, iphas, nf, nw, lags, &
             ldstak, ldsmin, ly, nfft, option)

  if (ierr==1) return

  alpha = 0.95e0
  delta = 1.0e0
!
!  compute covariances
!
  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)

  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)))

      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

  if (laglst <= 0) then
!
!  an error has been detected
!
     ierr = 2
     return
  end if
!
!  compute the vector of lag window truncation points, ordered
!  smallest to largest.
!
  nwused = nw
  if (.not.option(4)) call bfslag ( ccov, laglst, lags, n, nw, nwused, &
                                  iccov, jccov, index1, index2)
!
!  begin computing Fourier spectrum for series
!
  univar = .false.

  ilog = 0

  xpltmn = fmn
  xpltmx = fmx

  ypltmn = 0.0e0
  ypltmx = 1.0e0
!
!  set frequencies for the spectrum.
!
  call setfrq(freq, nf, 1, fmn, fmx, delta)
!
!  compute and plot spectrum values.
!
  newpg = .false.
!
!  compute the even and odd ccvf estimates
!
  ceven(1) = ccov(i3c(1,index1,index2))
  codd(1) = 0.0e0
  do 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)))
  end do

  do i = 1, nwused

    lag = lags(i)

    if ( laglst < lag ) then

      ispcer = 2
      df = 0.0e0

      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)

       newpg = .true.

    else

      ispcer = 0
!
!  compute the window, and effective degrees of freedom and
!  bandwidth based on the window
!
      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
!
!  compute the spectrum for each individual series
!
      call ufsest(ccov(i3c(1,index1,index1)), w, lag, spcf1, &
        nfused, iccov, lagmax, nf, freq, delta)

      call ufsest(ccov(i3c(1,index2,index2)), w, lag, spcf2, &
        nfused, iccov, lagmax, nf, freq, delta)

      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)

      if ( nprt /= 0 ) then

        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)

         newpg = .true.
      end if

    end if

  end do

  return
end
subroutine bfser ( nmsub, n, lagmax, iccov, jccov, inlppc, jnlppc, &
  m, index1, index2, icspc2, iphas, nf, nw, lags, &
  ldstak, ldsmin, lyfft, nfft, option )

!*****************************************************************************80
!
!! BFSER checks errors for time series Fourier univariate spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error(30)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index value.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer iphas
!        the first dimension of the array phas.
!     integer jccov
!        the first dimension of the array ccov.
!     integer jnlppc
!        the first dimension of the array nlppc.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to specify the lag window truncation
!        points used for each set of spectrum values.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     character*1 liccov(8), licspc(8), lindx1(8),
!    *   lindx2(8), linlpp(8), liphas(8), ljccov(8), ljnlpp(8),
!    *   llagmx(8), llags(8), llds(8), llgmx1(8), llyfft(8), lm(8),
!    *   ln(8), lnf(8), lnm1(8), lnw(8), l1(8)
!        the array(s) containing the name(s) of the argument(s)
!        checked for errors.
!     integer lyfft
!        the length of vector yfft.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in the series.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the array containing the name of the user called subroutine.
!     integer nv
!        the number of violations found when checking vector lags.
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!
  implicit none

  integer &
     iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, &
     lagmax,ldsmin,ldstak,lyfft,m,n,nf,nfft,nw
!
!  array arguments
  integer &
     lags(*)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,nv
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,eisii,eisle,eivii
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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', &
     ' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  error(1:30) = .false.
!
!  call error checking routines
!
  call eisge(nmsub, ln, n, 17, 1, head, error(1), ln)

  if ( option(3) ) then

    call eisii(nmsub, llagmx, lagmax, 1, n-1, 1, head, error(2), l1, &
      lnm1)

    call eisge(nmsub, lm, m, 2, 1, head, error(3), lm)

    call eisge(nmsub, liccov, iccov, lagmax+1, 3, head, error(4), &
      llgmx1)

    call eisge(nmsub, ljccov, jccov, m, 4, head, error(5), lm)

    if (option(2)) then
      call eisge(nmsub, linlpp, inlppc, lagmax+1, 3, head, error(6), &
        llgmx1)

      call eisge(nmsub, ljnlpp, jnlppc, m, 4, head, error(7), lm)
    end if

    call eisle(nmsub, lindx1, index1, m, 2, head, error(8), lm)

    call eisle(nmsub, lindx2, index2, m, 2, head, error(9), lm)

  end if

  call eisge(nmsub, llyfft, lyfft, nfft, 9, head, error(10), llyfft)

  if (option(1) .and. (.not.option(4))) call eisge(nmsub, llds, &
     ldstak, ldsmin, 9, head, error(15), llds)

  if ( .not. option(4)) then

    do i=1,15
      if ( error(i) ) then
        ierr = 1
        return
      end if
    end do

    return

  end if

  call eisge(nmsub, lnf, nf, 1, 1, head, error(16), lnf)

  call eisge(nmsub, lnw, nw, 1, 1, head, error(18), lnw)

  if ( .not. error(18) ) then
    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

  end if

  call eisge(nmsub, licspc, icspc2, nf, 3, head, error(24), lnf)

  call eisge(nmsub, liphas, iphas, nf, 3, head, error(25), lnf)

  if (error(2) .or. error(16) .or. error(18) .or. error(19)) then
    ierr = 1
    return
  end if

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(30), llds)

  do i=1,30
    if (error(i)) then
      ierr = 1
      return
    end if
  end do

  return
end
subroutine bfs ( y1, y2, n )

!*****************************************************************************80
!
!! BFS: short interface for time series Fourier bivariate spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real ccov(101,2,2)
!        the covariances.
!     real ceven(101)
!        the sums of the autocovariances for each lag.
!     real codd(101)
!        the differences of the autocovariances for each lag.
!     real cspc2(101,4)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer iphas
!        the first dimension of the array phas.
!     integer isym(404)
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer jnlppc
!        the second dimension of the array nlppc.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc(1,1,1)
!        a dummy array.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(101,4)
!        the phase component of the bivariate spectra.
!     real spcf1(101), spcf2(101)
!        the arrays in which the spectrum is stored.
!     real w(101)
!        the windows.
!     real xaxis(404)
!        the x axis values for the spectrum plots.
!     real yaxis(404)
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        dummy variables.
!     real y1(n)
!        the first time series.
!     real y2(n)
!        the second time series.
!
  implicit none

  integer n

  integer ierr
  real y1(n)
  real y2(n)

  real &
     alpha,delta,fmax,fmin,ymiss1,ymiss2
  integer &
     iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, &
     lagmax,lagmx1,ldsmin,ldstak,lpcv,lw,ly,m,nf,nprt,nw
!
!  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
!
!  external subroutines
  external bfsdrv,parzen,setlag
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s',' ',' ',' '/

  option(1) = .false.
  option(2) = .false.
  option(3) = .false.
  option(4) = .false.

  iccov = 101
  jccov = 2
  m = 2
  index1 = 1
  index2 = 2

  icspc2 = 101
  iphas = 101

  ldstak = 0
  ldsmin = 0

  nf = 101
  ymiss1 = 1.0e0
  ymiss2 = 1.0e0
  inlppc = 1
  jnlppc = 1
  lw = 101
  ly = n
  lpcv = 404
!
!  set maximum lag value (lagmax)
!  set number of lag window truccation points (nw)
!
  call setlag(n, lagmax)
  nw = 4
!
!  call the controling routine for the bivariate spectrum routines
!
  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)

  return
end
subroutine bfsf ( yfft1, yfft2, n, lyfft, ldstak )

!*****************************************************************************80
!
!! BFSF: short interface for time series Fourier bivariate spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real ccov(101,2,2)
!        the covariances.
!     real ceven(101)
!        the sums of the autocovariances for each lag.
!     real codd(101)
!        the differences of the autocovariances for each lag.
!     real cspc2(101,4)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer iphas
!        the first dimension of the array phas.
!     integer isym(404)
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer jnlppc
!        the second dimension of the array nlppc.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer lwork
!        the length of the vector work.
!     integer lyfft
!        the length of the vectors y1 and yfft1 and yfft2
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of stack allocations on entry
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     integer nlppc(1,1,1)
!        a dummy array.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(101,4)
!        the phase component of the bivariate spectra.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spcf1(101), spcf2(101)
!        the arrays in which the spectrum is stored.
!     real w(101)
!        the windows.
!     integer work
!        the starting location in the work area for
!        the work vector
!     real xaxis(404)
!        the x axis values for the spectrum plots.
!     real yaxis(404)
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        dummy variables.
!     real yfft1(lyfft)
!        the first time series.
!     real yfft2(lyfft)
!        the second time series.
!
  implicit none

  integer &
     ldstak,lyfft,n
!
!  array arguments
  real &
     yfft1(*),yfft2(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,fmax,fmin,ymiss1,ymiss2
  integer &
     iccov,icspc2,ifp,index1,index2,inlppc,iphas,jccov, &
     jnlppc,lagmax,lagmx1,ldsmin,lpcv,lw,lwork,m,nf,nfft, &
     nprt,nw,work
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external bfsdrv,ldscmp,parzen,setesl,setlag,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','f',' ',' '/

  option(1) = .true.
  option(2) = .false.
  option(3) = .false.
  option(4) = .false.

  iccov = 101
  jccov = 2
  m = 2
  index1 = 1
  index2 = 2

  icspc2 = 101
  iphas = 101

  ldsmin = 0

  nf = 101
  ymiss1 = 1.0e0
  ymiss2 = 1.0e0
  inlppc = 1
  jnlppc = 1
  lw = 101
  lpcv = 404
!
!  set maximum lag value (lagmax)
!  set number of lag window truccation points (nw)
!  set extended series length (nfft)
!
  call setlag(n, lagmax)
  nw = 4
  call setesl(n+lagmax, 4, nfft)
!
!  compute minimum allowable stack length (ldsmin)
!
  call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin)
!
!  set size of work area
!  set number of outstanding allocations (nall0)
!  set the stack allocation type (ifp)
!
  call stkset(ldstak, 4)

  ifp = 3
!
!  set the starting locations inthe work area for various arrays
!
  if ((ldsmin <= ldstak) .and. (ldsmin >= 7)) then
     work = stkget(nfft,ifp)
     lwork = nfft
  else
     work = 1
     lwork = 1
  end if
!
!  call the controling routine for the bivariate spectrum routines
!
  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)

  return
end
subroutine bfsfs ( yfft1, yfft2, n, lyfft, ldstak, nw, lags, nf, &
  fmin, fmax, nprt, cspc2, icspc2, phas, iphas, freq )

!*****************************************************************************80
!
!! BFSFS: long interface for time series Fourier bivariate spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     integer ccov, ccov11, ccov12, ccov21, ccov22
!        the starting location in the work area for
!        the covariances.
!     integer ceven
!        the starting location in the work area for
!        the sums of the autocovariances for each lag.
!     integer codd
!        the starting location in the work area for
!        the differences of the autocovariances for each lag.
!     real cspc2(icspc2,nw)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index value.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer iphas
!        the first dimension of the array phas.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer lwork
!        the length of the vector work.
!     integer lyfft
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of stack allocations on entry.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     integer nlppc(1,1,1)
!        a dummy array.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(iphas,nw)
!        the phase component of the bivariate spectra.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer spcf1, spcf2
!        the starting location in the work area for
!        the arrays in which the spectrum is stored.
!     integer w
!        the starting location in the work area for
!        the windows.
!     integer work
!        the starting location in the work area for the vector work.
!     integer xaxis
!        the starting location in the work area for
!        the x axis values for the spectrum plots.
!     integer yaxis
!        the starting location in the work area for
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        dummy variables.
!     real yfft1(lyfft)
!        the first time series.
!     real yfft2(lyfft)
!        the second time series.
!
  implicit none

  real &
     fmax,fmin
  integer &
     icspc2,iphas,ldstak,lyfft,n,nf,nprt,nw
!
!  array arguments
  real &
     cspc2(*),freq(*),phas(*),yfft1(*),yfft2(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,ymiss1,ymiss2
  integer &
     ccov
  integer ceven,codd,iccov,ifp, &
     index1,index2,inlppc,io,isym,jccov,jnlppc,lagmax, &
     lagmx1,ldsmin,lpcv,lw,lwork,m,nall0,nfft,spcf1,spcf2,w, &
     work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12),nlppc(1,1,1)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external bfsdrv,ldscmp,parzen,setesl,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','f','s',' '/

  option(1) = .false.
  option(2) = .false.
  option(3) = .false.
  option(4) = .true.
!
!  Set maximum lag value to be used.
!
  if ( 1 <= nw ) then
     lagmax = maxval ( lags(1:nw) )
  else
     lagmax = n - 1
  end if

  lagmx1 = lagmax + 1
  call setesl(n+lagmax, 4, nfft)

  iccov = lagmax + 1
  jccov = 2
  inlppc = 1
  jnlppc = 1
  m = 2
  index1 = 1
  index2 = 2
!
!  compute the minimum allowable stack area
!
  if (nprt==0) then
     io = 0
  else
     io = 1
  end if

  call ldscmp(9, 0, io*4*nf, 0, 0, 0, 's', &
              6*lagmax+6+nfft+io*8*nf, ldsmin)

  ymiss1 = 1.0e0
  ymiss2 = 1.0e0
  lpcv = 4*nf
  lw = nfft
!
!  set size of work area.
!  set the number of outstanding stack allocations (nall0)
!  set the stack allocation type (ifp)
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays
!
  if ((ldsmin > ldstak) .or. ldsmin <= 6 ) then
     ccov = 1
     ceven = 1
     codd = 1
     spcf1 = 1
     spcf2 = 1
     w = 1

     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)

     if (nprt==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

  work = w
  lwork = lw
!
!  call the controlling routine for the bivariate spectrum routines
!
  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)

  call stkclr(nall0)

  return
end
subroutine bfslag ( ccov, lagmax, lags, n, nw, nwused, iccov, &
  jccov, index1, index2 )

!*****************************************************************************80
!
!! BFSLAG: lag window truncation points for Fourier bivariate spectral analysis.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov(iccov,jccov,*)
!        the covariances.
!     real covmx
!        the maximum covariance value.
!     real covmxi
!        the maximum covariance value for the ith lag.
!     real fac11, fac12, fac21, fac22
!        factors used to compute the correlation coefficients.
!     integer iccov
!        the first dimension of the array ccov.
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer jccov
!        the second dimension of the array ccov..
!     integer lag, lagmax
!        the indexing variable indicating the lag value of the
!        bivariate covariance being computed and the maximum lag
!        to be used, respectively.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer n
!        the integer number of observations in each series
!     integer nw
!        the number of different bandwidths requested.
!     integer nwused
!        the actual number of bandwidths used.
!     real p95lim
!        the 95 percent confident limit for white noise.
!
  implicit none

  integer iccov
  integer jccov

  real ccov(iccov,jccov,*)
  real covmx
  real covmxi
  real fac11
  real fac12
  real fac21
  real fac22
  integer i
  integer index1
  integer index2
  integer j
  integer k
  integer lag
  integer lagmax
  integer lags(*)
  integer n
  integer nw
  integer nwused
  real p95lim

  lags(nw) = lagmax
  if (lags(nw) <= 32) go to 30
!
!  compute 95 percent confidence limits on bivariatecovariances,
!  assuming white noise.
!
  p95lim = 1.96e0 / sqrt(real(n))

  fac11 = ccov(1,index1,index1)
  fac12 = sqrt(ccov(1,index1,index1)*ccov(1,index2,index2))
  fac21 = fac12
  fac22 = ccov(1,index2,index2)
!
!  Check for first cvf exceeding 95 percent limit on white noise
!
  do 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 >= p95lim) go to 30
     lags(nw) = lags(nw) - 1
  end do
!
!  if no acvf exceeds white noise limits, check for largest acvf.
!
  lags(nw) = 1
  covmx = abs(ccov(2,1,1)*fac11)

  do 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 ( covmx < covmxi ) then
       lags(nw) = lag
       covmx = covmxi
     end if

  end do
!
!  compute lag window truncation points
!
30 continue

  lags(nw) = int ( real ( lags(nw) ) *3.0e0 / 2.0e0 )
  if (lags(nw)<32) lags(nw) = 32
  if (lags(nw) > lagmax) lags(nw) = lagmax
  nwused = nw
  if (nw==1) return

  do i = 1, nw - 1
     k = nw - i
     lags(k) = lags(k+1)/2
  end do
!
!  check whether all nw lag window truncation points can be used.
!
  nwused = nw
  if (lags(1) >= 4) return
!
!  reconsturct -lags- vector if not all truncation points are
!  to be used
!
  do i=2,nw
    nwused = nwused - 1
    if (lags(i) >= 4) then
      exit
    end if
  end do

  do i=1,nwused
     j = nw - nwused + i
     lags(i) = lags(j)
   end do

  return
end
subroutine bfsm ( y1, ymiss1, y2, ymiss2, n )

!*****************************************************************************80
!
!! BFSM: short interface for time series bivariate Fourier spectrum analysis.
!
!  Discussion:
!
!    This is the user callable routine for time series bivariate
!    Fourier spectrum analysis of series with missing observations
!    (short call)
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real ccov(101,2,2)
!        the covariances.
!     real ceven(101)
!        the sums of the autocovariances for each lag.
!     real codd(101)
!        the differences of the autocovariances for each lag.
!     real cspc2(101,4)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer iphas
!        the first dimension of the array phas.
!     integer isym(404)
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer jnlppc
!        the second dimension of the array nlppc.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc(101,2,2)
!        the number of observations in each covariance estimate
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(101,4)
!        the phase component of the bivariate spectra.
!     real spcf1(101), spcf2(101)
!        the arrays in which the spectrum is stored.
!     real w(101)
!        the windows.
!     real xaxis(404)
!        the x axis values for the spectrum plots.
!     real yaxis(404)
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        the missing value codes
!     real y1(n)
!        the first time series.
!     real y2(n)
!        the second time series.
!
  implicit none

  integer n

  real &
     ymiss1,ymiss2

  real &
     y1(n),y2(n)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     alpha,delta,fmax,fmin
  integer &
     iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, &
     lagmax,lagmx1,ldsmin,ldstak,lpcv,lw,ly,m,nf,nprt,nw
!
!  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
!
!  external subroutines
  external bfsdrv,ecvf,parzen,setlag
!
!  common blocks
  common /errchk/ierr
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','m',' ',' '/

  option(1) = .false.
  option(2) = .true.
  option(3) = .false.
  option(4) = .false.

  iccov = 101
  jccov = 2
  m = 2
  index1 = 1
  index2 = 2

  icspc2 = 101
  iphas = 101

  ldstak = 0
  ldsmin = 0

  nf = 101
  inlppc = 101
  jnlppc = 2
  lw = 101
  ly = n
  lpcv = 404
!
!  LAGMAX is the maximum lag value.
!
  call setlag ( n, lagmax )
!
!  NW is the number of lag window truncation points.
!
  nw = 4
!
!  Call the controlling routine for the bivariate spectrum routines.
!
  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)

  if ( ierr  /=  0 ) then
    if ( ierr == 2 ) then
      call ecvf(nmsub)
    end if
    ierr = 1
  end if

  return
end
subroutine bfsmn ( spcf1, spcf2, ceven, codd, w, lw, lag, df, nprt, &
  nf, cspc2, phas, freq, npts, xaxis, yaxis, isym, lpcv, alpha, &
  lagmx1, delta )

!*****************************************************************************80
!
!! BFSMN computes square coherency and phase components of a bivariate spectrum.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Steven Keefer,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Gwilym Jenkins, Donald Watts,
!    Spectral Analysis and its Applications,
!    Holden-Day 1968.
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real arg
!        an argument used in the spectrum computations.
!     real barl
!        the smoothed cospectral estimates.
!     real barq
!        the smoothed quadrature spectral estimates.
!     real bary
!        a transformation of the squared coherency component.
!     real c
!        an argument used in the spectrum computations.
!     real ceven(lagmx1)
!        the sums of the covariances for each lag.
!     real ci
!        the confidence interval for the squared coherency component.
!     real codd(lagmx1)
!        the differences of the autocovariances for each lag.
!     real cspc2(nf)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     real df
!        the effective degrees of freedom.
!     real fplm
!        the floating point largest magnitude.
!     real freq(nf)
!        the frequencies at which the spectrum is computed.
!     real g
!        an argument used in the computation of the alpha percent
!        significance level.
!     integer i
!        an index value.
!     integer isym(lpcv)
!        the vector containing the codes for the plot symbols.
!     integer k
!         an index value.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmx1
!        the value lagmax+1.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!         the length of vector w.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt = 0 the plot is suppressed.
!        if nprt = 2 the plot is provided.
!     integer npts
!        the number of x, y coordinates to be plotted.
!     real phas(nf)
!        the phase component of the bivariate spectra.
!     real pi, pit2
!        the value of pi and pi*2.
!     real sn
!        an argument used in the computation of the spectrum.
!     real spcf1(nf), spcf2(nf)
!        the univariate spectrum for each series.
!     real v0, v1, v2
!        arguments used in the computation of the spectrum.
!     real w(lw)
!        the window.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plots.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plots.
!     real z0, z1, z2
!        arguments used in the computation of the spectrum.
!
  implicit none

  real &
     alpha,delta,df
  integer &
     lag,lagmx1,lpcv,lw,nf,nprt,npts
!
!  array arguments
  real &
     ceven(lagmx1),codd(lagmx1),cspc2(*),freq(*),phas(*),spcf1(*),spcf2(*), &
     w(lw),xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(*)
!
!
  real &
     arg,barl,barq,bary,c,ci,fplm,g,pi,pit2,sn,v0, &
     v1,v2,z0,z1,z2
  integer &
     i,k
!
!  external functions
  real &
     ppfnml
  external ppfnml
!
!  external subroutines
  external getpi
!
  call getpi(pi)
  pit2 = pi*2.0e0

  fplm = huge ( fplm )
!
!  compute smoothed co-spectral estimate
!
  do i=1,nf
!
!  compute smoothed co- and quadrature spectra using
!  the algorithm shown on page 420 of jenkins and watts
!
     if (freq(i)==0.0e0) then
        c = 1.0e0
        sn = 0.0e0
     else if (freq(i)==0.25e0) then
        c = 0.0e0
        sn = 1.0e0
     else if (freq(i)==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 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
     end do

     barl = delta*(ceven(1)+2.0e0*(v1*c-v0))
     barq = 2.0e0*delta*z1*sn
!
!  Compute the smoothed squared coherency spectra.
!
     if (spcf1(i)*spcf2(i) > 0.0e0) then
        cspc2(i) = (barl*barl+barq*barq)
        cspc2(i) = cspc2(i)/(spcf1(i)*spcf2(i))
     else
        cspc2(i) = fplm
     end if
!
!  compute phase (in radians)
!
     if ((barq /= 0.0e0) .or. (barl /= 0.0e0)) then
        phas(i) = atan2(-barq,barl)
     else
        if (i==1) then
           phas(i) = 0.0e0
        else
           phas(i) = sign(pi,phas(i-1))
        end if
     end if

  end do

  if (nprt==0) return
!
!  compute smoothed squared coherency plot vectors
!
  ci = ppfnml(alpha)*sqrt(1.0e0/df)
  g = 2.0e0/df
  g = 1.0e0 - (1.0e0-alpha)**(g/(1.0e0-g))
  npts = 0

  do i = 1, nf

     npts = npts + 1
!
!  compute 95 per cent significance level
!
     yaxis(npts) = g
     xaxis(npts) = freq(i)
     isym(npts) = 4

     if ( spcf1(i)*spcf2(i) <= 0.0e0 ) then
       cycle
     end if
!
!  compute coherence spectral estimate
!
     if ( cspc2(i)  >  1.0e0 ) then
       cycle
     end if

     npts = npts + 1
     yaxis(npts) = cspc2(i)
     xaxis(npts) = freq(i)
     isym(npts) = 1

     if (cspc2(i)<g) then
       cycle
     end if
!
!  compute confidence interval
!
     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

  end do

  return
end
subroutine bfsms ( y1, ymiss1, y2, ymiss2, n, nw, lags, nf, fmin, &
  fmax, nprt, cspc2, icspc2, phas, iphas, freq, ldstak )

!*****************************************************************************80
!
!! BFSMS: long interface for BFS analysis with missing observations.
!
!  Discussion:
!
!    This is the user callable routine for time series bivariate
!    Fourier spectrum analysis of series with missing observations
!    (long call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     integer ccov
!        the starting location in the work area for
!        the covariances.
!     integer ceven
!        the starting location in the work area for
!        the sums of the autocovariances for each lag.
!     integer codd
!        the starting location in the work area for
!        the differences of the autocovariances for each lag.
!     real cspc2(icspc2,nw)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index value.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer iphas
!        the first dimension of the array phas.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer lwork
!        the length of the vector work.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of stack allocations on entry.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc
!        the starting location in the work area for nlppc
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(iphas,nw)
!        the phase component of the bivariate spectra.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer spcf1, spcf2
!        the starting location in the work area for
!        the arrays in which the spectrum is stored.
!     integer w
!        the starting location in the work area for
!        the windows.
!     integer work
!        the starting location in the work area for the vector work.
!     integer xaxis
!        the starting location in the work area for
!        the x axis values for the spectrum plots.
!     integer yaxis
!        the starting location in the work area for
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        dummy variables.
!     real y1(n)
!        the first time series.
!     real y2(n)
!        the second time series.
!
  implicit none

  real &
     fmax,fmin,ymiss1,ymiss2
  integer &
     icspc2,iphas,ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     cspc2(*),freq(*),phas(*),y1(*),y2(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta
  integer &
     ccov,ceven,codd,iccov,ifp,index1,index2,inlppc,io,  &
     isym,jccov,jnlppc,lagmax,lagmx1,ldsmin,lpcv,lw,lwork,ly,m, &
     nall0,nlppc,spcf1,spcf2,w,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external bfsdrv,ecvf,ldscmp,parzen,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','m','s',' '/

  option(1) = .false.
  option(2) = .true.
  option(3) = .false.
  option(4) = .true.
!
!  Set maximum lag value to be used (lagmax).
!
  if ( nw <= 0 ) then
    lagmax = n - 1
  else
    lagmax = maxval ( lags(1:nw) )
  end if

  lagmx1 = lagmax + 1

  iccov = lagmax + 1
  jccov = 2
  inlppc = lagmax + 1
  jnlppc = 2
  m = 2
  index1 = 1
  index2 = 2
!
!  compute the minimum allowable stack area (ldsmin)
!
  io = 1
  if (nprt==0) io = 0

  call ldscmp(10, 0, 4*lagmax + 4 + io*4*nf, 0, 0, 0, 's', &
    7*lagmax+7+2*nf+io*8*nf, ldsmin)

  ly = n
  lpcv = 4*nf
  lw = lagmx1
!
!  set size of work area.
!  set the number of outstanding stack allocations (nall0).
!  set the stack allocation type (ifp)
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then
     ccov = 1
     nlppc = 1
     ceven = 1
     codd = 1
     spcf1 = 1
     spcf2 = 1
     w = 1

     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==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

  work = w
  lwork = lw
!
!  call the controling routine for the bivariate spectrum routines
!
  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)

  call stkclr(nall0)
!
!  check for errors
!
  if (ierr /= 0) then
    if (ierr==2) call ecvf(nmsub)
    ierr = 1
  end if

  return
end
subroutine bfsmv ( ccov, nlppc, index1, index2, n, lagmax, iccov, &
  jccov, inlppc, jnlppc )

!*****************************************************************************80
!
!! BFSMV: short interface for BFS analysis, missing observations, covariances.
!
!  Discussion:
!
!    This is the user callable routine for time series bivariate
!    Fourier spectrum analysis of series with missing observations
!    and covariances input rather than original series
!    (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real ccov(iccov,jccov,*)
!        the covariances.
!     real ceven(101)
!        the sums of the autocovariances for each lag.
!     real codd(101)
!        the differences of the autocovariances for each lag.
!     real cspc2(101,4)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer iphas
!        the first dimension of the array phas.
!     integer isym(404)
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer jnlppc
!        the second dimension of the array nlppc.
!     integer lagmax, lagmxu
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc(inlppc,jnlppc,*)
!        the number of observations in each covariance estimate
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(101,4)
!        the phase component of the bivariate spectra.
!     real spcf1(101), spcf2(101)
!        the arrays in which the spectrum is stored.
!     real w(101)
!        the windows.
!     real xaxis(404)
!        the x axis values for the spectrum plots.
!     real yaxis(404)
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        the missing value codes
!     real y1(1)
!        the first time series.
!     real y2(1)
!        the second time series.
!
  implicit none

  integer &
     iccov,index1,index2,inlppc,jccov,jnlppc,lagmax,n
!
!  array arguments
  real &
     ccov(*)
  integer &
     nlppc(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     alpha,delta,fmax,fmin,ymiss1,ymiss2
  integer &
     icspc2,iphas,lagmx1,lagmxu,ldsmin,ldstak,lpcv,lw,ly, &
     m,nf,nprt,nw
!
!  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
!
!  external subroutines
  external bfsdrv,ecvf,parzen,setlag
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','m','v',' '/

  option(1) = .false.
  option(2) = .true.
  option(3) = .true.
  option(4) = .false.

  m = 2

  icspc2 = 101
  iphas = 101

  ldstak = 0
  ldsmin = 0

  nf = 101
  lw = 101
  ly = n
  lpcv = 404
!
!  set maximum lag value used (lagmxu)
!  set number of lag window truccation points (nw)
!
  call setlag(n, lagmxu)
  lagmxu = min(lagmxu,lagmax)
  nw = 4
!
!  call the controling routine for the bivariate spectrum routines
!
  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)

  if (ierr /= 0) then
    if (ierr==2) call ecvf(nmsub)
    ierr = 1
  end if

  return
end
subroutine bfsmvs ( ccov, nlppc, index1, index2, n, iccov, jccov, &
  inlppc, jnlppc, nw, lags, nf, fmin, &
  fmax, nprt, cspc2, icspc2, phas, iphas, freq, ldstak )

!*****************************************************************************80
!
!! BFSMVS: long interface for BFS analysis, missing observations, covariances.
!
!  Discussion:
!
!    This is the user callable routine for time series bivariate
!    Fourier spectrum analysis of series with missing observations
!    with user input of the covariances rather than the series
!    (long call)
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real ccov(iccov,jccov,*)
!        the covariances.
!     integer ceven
!        the starting location in the work area for
!        the sums of the autocovariances for each lag.
!     integer codd
!        the starting location in the work area for
!        the differences of the autocovariances for each lag.
!     real cspc2(icspc2,nw)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index value.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer iphas
!        the first dimension of the array phas.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer lwork
!        the length of the vector work.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of stack allocations on entry.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc(inlppc,jnlppc,*)
!        the number of observations in each covariance estimate
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(iphas,nw)
!        the phase component of the bivariate spectra.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer spcf1, spcf2
!        the starting location in the work area for
!        the arrays in which the spectrum is stored.
!     integer w
!        the starting location in the work area for
!        the windows.
!     integer work
!        the starting location in the work area for the vector work.
!     integer xaxis
!        the starting location in the work area for
!        the x axis values for the spectrum plots.
!     integer yaxis
!        the starting location in the work area for
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        dummy variables.
!     real y1(1)
!        the first time series.
!     real y2(1)
!        the second time series.
!
  implicit none

  real fmax
  real fmin
  external parzen

  integer &
     iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, &
     ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     ccov(*),cspc2(*),freq(*),phas(*)
  integer &
     lags(*),nlppc(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,ymiss1,ymiss2
  integer &
     ceven,codd,ifp,io,isym,lagmax,lagmx1,ldsmin,lpcv, &
     lw,lwork,ly,m,nall0,spcf1,spcf2,w,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12),y1(1),y2(1)
  integer &
     istak(12)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','m','v','s'/

  option(1) = .false.
  option(2) = .true.
  option(3) = .true.
  option(4) = .true.
!
!  set maximum lag value to be used (lagmax).
!
  if ( nw <= 0 ) then
    lagmax = n - 1
  else
    lagmax = maxval ( lags(1:nw) )
  end if
  lagmx1 = lagmax + 1

  m = 2
!
!  compute the minimum allowable stack area (ldsmin)
!
  io = 1
  if (nprt==0) io = 0

  call ldscmp(8, 0, io*4*nf, 0, 0, 0, 's', &
    7*lagmax+7+2*nf+io*8*nf, ldsmin)

  ly = n
  lpcv = 4*nf
  lw = lagmax + 1
!
!  set size of work area.
!  set the number of outstanding stack allocations (nall0).
!  set the stack allocation type (ifp)
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then
     ceven = 1
     codd = 1
     spcf1 = 1
     spcf2 = 1
     w = 1
     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==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

  work = w
  lwork = lw
!
!  call the controling routine for the bivariate spectrum routines
!
  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)

  call stkclr(nall0)
!
!     check for errors
!
  if (ierr /= 0) then
    if (ierr==2) call ecvf(nmsub)
    ierr = 1
  end if

  return
end
subroutine bfss ( y1, y2, n, nw, lags, nf, fmin, fmax, nprt, cspc2, &
  icspc2, phas, iphas, freq, ldstak )

!*****************************************************************************80
!
!! BFSS: long call for time series bivariate Fourier spectrum analysis.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     integer ccov, ccov11, ccov12, ccov21, ccov22
!        the starting location in the work area for
!        the covariances.
!     integer ceven
!        the starting location in the work area for
!        the sums of the autocovariances for each lag.
!     integer codd
!        the starting location in the work area for
!        the differences of the autocovariances for each lag.
!     real cspc2(icspc2,nw)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index value.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer iphas
!        the first dimension of the array phas.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer lwork
!        the length of the vector work.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of stack allocations on entry.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc(1,1,1)
!        a dummy array.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt = 0 the plot is suppressed.
!        if nprt = 1 the plot is provided.
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(iphas,nw)
!        the phase component of the bivariate spectra.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer spcf1, spcf2
!        the starting location in the work area for
!        the arrays in which the spectrum is stored.
!     integer w
!        the starting location in the work area for
!        the windows.
!     integer work
!        the starting location in the work area for the vector work.
!     integer xaxis
!        the starting location in the work area for
!        the x axis values for the spectrum plots.
!     integer yaxis
!        the starting location in the work area for
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        dummy variables.
!     real y1(n)
!        the first time series.
!     real y2(n)
!        the second time series.
!
  implicit none

  real fmax
  real fmin
  external parzen

  integer &
     icspc2,iphas,ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     cspc2(*),freq(*),phas(*),y1(*),y2(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,ymiss1,ymiss2
  integer &
     ccov

!integer ccov11,ccov12,ccov21,ccov22

  integer ceven,codd,iccov,ifp, &
     index1,index2,inlppc,io,isym,jccov,jnlppc,lagmax, &
     lagmx1,ldsmin,lpcv,lw,lwork,ly,m,nall0,spcf1,spcf2,w,work, &
     xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12),nlppc(1,1,1)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))

!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','s',' ',' '/

  option(1) = .false.
  option(2) = .false.
  option(3) = .false.
  option(4) = .true.
!
!  set maximum lag value to be used (lagmax).
!
  if (nw >= 1) then
    lagmax = maxval ( lags(1:nw) )
  else
    lagmax = n - 1
  end if
  lagmx1 = lagmax + 1

  iccov = lagmax + 1
  jccov = 2
  inlppc = 1
  jnlppc = 1
  m = 2
  index1 = 1
  index2 = 2
!
!  compute the minimum allowable stack area (ldsmin)
!
  io = 1
  if (nprt == 0) io = 0

  call ldscmp(9, 0, io*4*nf, 0, 0, 0, 's', &
              7*lagmax+7+io*8*nf, ldsmin)

  ly = n
  ymiss1 = 1.0e0
  ymiss2 = 1.0e0
  lpcv = 4*nf
  lw = lagmax + 1
!
!  set size of work area.
!  set the number of outstanding stack allocations (nall0).
!  set the stack allocation type (ifp)
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then
     ccov = 1
     ceven = 1
     codd = 1
     spcf1 = 1
     spcf2 = 1
     w = 1

!    ccov11 = 1
!    ccov21 = 1
!    ccov12 = 1
!    ccov22 = 1

     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)

!    ccov11 = ccov
!    ccov21 = ccov + lagmx1
!    ccov12 = ccov21 + lagmx1
!    ccov22 = ccov12 + lagmx1

     if (nprt == 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

  work = w
  lwork = lw
!
!  Call the controlling routine for the bivariate spectrum routines
!
  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)

  call stkclr(nall0)

  return
end
subroutine bfsv ( ccov, index1, index2, n, lagmax, iccov, jccov )

!*****************************************************************************80
!
!! BFSV: short call for BFS analysis, with covariance input rather than series.
!
!  Discussion:
!
!    This is the user callable routine for time series bivariate
!    Fourier spectrum analysis of series with
!    covariances input rather than original series
!    (short call)
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real ccov(iccov,jccov,*)
!        the covariances.
!     real ceven(101)
!        the sums of the autocovariances for each lag.
!     real codd(101)
!        the differences of the autocovariances for each lag.
!     real cspc2(101,4)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer iphas
!        the first dimension of the array phas.
!     integer isym(404)
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer jnlppc
!        the second dimension of the array nlppc.
!     integer lagmax, lagmxu
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc(1,1,1)
!        a dummy array.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(101,4)
!        the phase component of the bivariate spectra.
!     real spcf1(101), spcf2(101)
!        the arrays in which the spectrum is stored.
!     real w(101)
!        the windows.
!     real xaxis(404)
!        the x axis values for the spectrum plots.
!     real yaxis(404)
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        the missing value codes
!     real y1(1)
!        the first time series.
!     real y2(1)
!        the second time series.
!
  implicit none

  integer &
     iccov,index1,index2,jccov,lagmax,n
!
!  array arguments
  real &
     ccov(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     alpha,delta,fmax,fmin,ymiss1,ymiss2
  integer &
     icspc2,inlppc,iphas,jnlppc,lagmx1,lagmxu,ldsmin, &
     ldstak,lpcv,lw,ly,m,nf,nprt,nw
!
!  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
!
!  external subroutines
  external bfsdrv,parzen,setlag
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','v',' ',' '/

  option(1) = .false.
  option(2) = .false.
  option(3) = .true.
  option(4) = .false.

  m = 2

  inlppc = 1
  jnlppc = 1
  icspc2 = 101
  iphas = 101

  ldstak = 0
  ldsmin = 0

  nf = 101
  lw = 101
  ly = n
  lpcv = 404
!
!  set maximum lag value used (lagmxu)
!  set number of lag window truccation points (nw)
!
  call setlag(n, lagmxu)
  lagmxu = min(lagmxu,lagmax)
  nw = 4
!
!  call the controling routine for the bivariate spectrum routines
!
  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)

  return
end
subroutine bfsvs ( ccov, index1, index2, n, iccov, jccov, &
  nw, lags, nf, fmin, fmax, nprt, cspc2, icspc2, phas, iphas, &
  freq, ldstak )

!*****************************************************************************80
!
!! BFSVS: long call for BFS analsys with covariances input rather than series.
!
!  Discussion:
!
!    This is the user callable routine for time series bivariate
!    Fourier spectrum analysis of series with
!    user input of the covariances rather than the series
!    (long call)
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real alpha
!        the desired confidence level.
!     real ccov(iccov,jccov,*)
!        the covariances.
!     integer ceven
!        the starting location in the work area for
!        the sums of the autocovariances for each lag.
!     integer codd
!        the starting location in the work area for
!        the differences of the autocovariances for each lag.
!     real cspc2(icspc2,nw)
!        the squared coherency component of the bivariate spectra.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the
!        spectrum is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index value.
!     integer iccov
!        the first dimension of the array ccov.
!     integer icspc2
!        the first dimension of the array cspc2.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer index1, index2
!        the indices of the covariances of the two series.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer iphas
!        the first dimension of the array phas.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for
!        the array containing the code for the plot symbols.
!     integer jccov
!        the second dimension of the array ccov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lagmx1
!        lagmax+1.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lw
!        the length of the vector w.
!     integer lwork
!        the length of the vector work.
!     integer ly
!        the length of the vectors y1 and y2.
!     integer m
!        the number of series for which the covariances were
!        computed
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of stack allocations on entry.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppc(1,1,1)
!        the number of observations in each covariance estimate
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        a code used to specify the type of plot.
!        if nprt < 0 the plot is decibels/linear
!        if nprt = 0 the plot is suppressed.
!        if nprt > 0 the plot is log/linear
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real phas(iphas,nw)
!        the phase component of the bivariate spectra.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer spcf1, spcf2
!        the starting location in the work area for
!        the arrays in which the spectrum is stored.
!     integer w
!        the starting location in the work area for
!        the windows.
!     integer work
!        the starting location in the work area for the vector work.
!     integer xaxis
!        the starting location in the work area for
!        the x axis values for the spectrum plots.
!     integer yaxis
!        the starting location in the work area for
!        the y axis values for the spectrum plots.
!     real ymiss1, ymiss2
!        dummy variables.
!     real y1(1)
!        the first time series.
!     real y2(1)
!        the second time series.
!
  implicit none

  real &
     fmax,fmin
  integer &
     iccov,icspc2,index1,index2,iphas,jccov,ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     ccov(*),cspc2(*),freq(*),phas(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,ymiss1,ymiss2
  integer &
     ceven,codd,ifp,inlppc,io,isym,jnlppc,lagmax,lagmx1, &
     ldsmin,lpcv,lw,lwork,ly,m,nall0,spcf1,spcf2,w,work,xaxis, &
     yaxis
!
!  local arrays
  real &
     rstak(12),y1(1),y2(1)
  integer &
     istak(12),nlppc(1,1,1)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external bfsdrv,ldscmp,parzen,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'b','f','s','v','s',' '/

  option(1) = .false.
  option(2) = .false.
  option(3) = .true.
  option(4) = .true.
!
!  set maximum lag value to be used (lagmax).
!
  if ( nw <= 0 ) then
    lagmax = n - 1
  else
    lagmax = maxval ( lags(1:nw) )
  end if
  lagmx1 = lagmax + 1

  m = 2
!
!  compute the minimum allowable stack area (ldsmin)
!
  io = 1
  if (nprt == 0) io = 0

  call ldscmp(8, 0, io*4*nf, 0, 0, 0, 's', &
    3*lagmax+3+2*nf+io*8*nf, ldsmin)

  inlppc = 1
  jnlppc = 1
  ly = n
  lpcv = 4*nf
  lw = lagmax + 1
!
!  set size of work area.
!  set the number of outstanding stack allocations (nall0).
!  set the stack allocation type (ifp)
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 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 == 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

  work = w
  lwork = lw
!
!  call the controling routine for the bivariate spectrum routines
!
  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)

  call stkclr(nall0)

  return
end
subroutine ccfer ( nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, &
  inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong )

!*****************************************************************************80
!
!! CCFER does error checking for CCF routines.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical err(15)
!        values indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer iccov
!        the first dimension of the array ccov.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!     integer inlppc
!        the first dimension of the array nlppc.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     logical islong
!        the indicator variable used to designate whether the calling
!        routine has suffix s (islong = true) or not (islong = false)
!     integer iym, iymfft
!        the first dimension of the arrays ym and ymfft, respectively.
!     integer jccov, jnlppc
!        the second dimensions of the arrays ccov and nlppc,
!        respectively.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 liccov(8), linlpp(8), liym(8), liymff(8), ljccov(8),
!    *  ljnlpp(8), llagmx(8), llds(8), llgmx1(8), llyfft(8),
!    *  lm(8), ln(8), lnfft(8), lnm1(8), lone(8), lthree(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer m
!        the number of series being analyzed
!     integer n
!        the integer number of observations in each series
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!
  implicit none

  integer &
     iccov,inlppc,iym,iymfft,jccov,jnlppc,lagmax,ldsmin,ldstak, &
     lyfft,m,n,nfft
  logical &
     isfft,islong
!
!  array arguments
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,eisii
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',' ',' ',' '/

  ierr = 0
  head = .true.
  err(1:15) = .false.
!
!  call error checking routines
!
  call eisge(nmsub, ln, n, 3, 2, head, err(1), lthree)

  call eisge(nmsub, lm, m, 1, 2, head, err(2), lone)

  if (.not.err(1)) then

    call eisii(nmsub, llagmx, lagmax, 1, n-1, 1, head, err(3), lone, &
      lnm1)

    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

    if (.not.err(3)) then

      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

      call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(9), llds)

    end if
  end if

  do i = 1, 15
    if (err(i)) ierr = 1
  end do

  return
end
subroutine ccf ( y1, y2, n )

!*****************************************************************************80
!
!! CCF computes the cross-correlation of two time series.
!
!  Discussion:
!
!    This is the user callable routine for computing the cross
!    correlations of two time series (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov(101, 2, 2)
!        the ccvf matrix.
!     integer iccov
!        the actual first dimension of the array ccov, as
!        specified in the users program.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer inlppc
!        the actual first dimension of the array nlppc as specifiec
!        in the users program.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     logical islong
!        the indicator variable used to designate whether the calling
!        routine has suffix s (islong = true) or not (islong = false)
!     integer iym
!        the actual first dimension of the matrix ym as
!        specified in the users program.
!     integer iymfft
!        the actual first dimension of the matrix ymfft as
!        specified in the users program.
!     integer jccov
!        the actual second dimension of the array ccov, as
!        specified in the users program.
!     integer jnlppc
!        the second dimension of the array nlppc as specified
!        in the users program.
!     integer lagmax
!        the number of autocorrelations desired.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the length of the vector yfft.
!     integer m
!        the number of series being compared, ie the
!        number of columns of data in ym.
!     integer n
!        the integer number of observations in each series
!     integer ndum(1)
!        a dummy dimensioned variable.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     real rhoc(201)
!        the array containing the ccf.
!     real sdrhoc(201)
!        the array containing the sd of the ccf.
!     real y1(n), y1mean, y1sd
!        the first series, and its mean and standard deviation.
!     real y2(n), y2mean, y2sd
!        the second series, and its mean and standard deviation.
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     y1(*),y2(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     y1mean,y1sd,y2mean,y2sd
  integer &
     iccov,inlppc,iym,iymfft,jccov,jnlppc,lagmax,ldsmin, &
     ldstak,lyfft,m,nfft
  logical &
     isfft,islong
!
!  local arrays
  real &
     ccov(101,2,2),rhoc(201),sdrhoc(201)
  integer &
     ndum(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external acvf,ccfer,ccfmn,ccfout,setlag
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'c',       'c',       'f',       ' ',       ' ',       ' '/

  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.
!
!  call error checking routines
!
  call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, &
    inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong)
!
!  check whether an error has been detected
!
  if (ierr == 0) then
!
!  set the maximum lag value to be used.
!
    call setlag (n, lagmax)
!
!  compute the series acvf and sd
!
    call acvf (y1, n, y1mean, ccov(1,1,1), lagmax, 101)
    y1sd = sqrt(ccov(1,1,1) * real ( n ) / real ( n - 1 ))

    call acvf (y2, n, y2mean, ccov(1,2,2), lagmax, 101)
    y2sd = sqrt(ccov(1,2,2) * real ( n ) / real(n-1) )
!
!  call routine for main autocorrelation computations.
!
    if (ccov(1,1,1)*ccov(1,2,2)  /=  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)
!
!  call routine to print out autocorrelations
!
    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

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine ccff ( yfft1, yfft2, n, lyfft, ldstak )

!*****************************************************************************80
!
!! CCFF computes the cross-correlation of two time series by Singleton's FFT.
!
!  Discussion:
!
!    This is the user callable routine for computing the cross
!    correlations of two time series using the singleton fft
!    (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov(101, 2, 2)
!        the ccvf matrix.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer iccov
!        the actual first dimension of the array ccov, as
!        specified in the users program.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer inlppc
!        the actual first dimension of the array nlppc as specifiec
!        in the users program.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     logical islong
!        the indicator variable used to designate whether the calling
!        routine has suffix s (islong = true) or not (islong = false)
!     integer iymfft
!        the actual first dimension of the matrix ymfft as
!        specified in the users program.
!     integer jccov
!        the actual second dimension of the array ccov, as
!        specified in the users program.
!     integer jnlppc
!        the second dimension of the array nlppc as specified
!        in the users program.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the number of locations in the array yfft1 and yfft2.
!     integer m
!        the number of series being compared, ie the
!        number of columns of data in ym.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     integer ndum(1)
!        a dummy array.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     real rhoc(201)
!        the array containing the ccf.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real sdrhoc(201)
!        the array containing the sd of the ccf.
!     real stak(12)
!        the used version of the /cstak/ work area.
!     integer work
!        the starting location in dstak for
!        the work array needed by the fft.
!     real yfft1(n), y1mean, y1sd
!        the first series, and its mean and standard deviation.
!     real yfft2(n), y2mean, y2sd
!        the second series, and its mean and standard deviation.
!
  implicit none

  integer &
     ldstak,lyfft,n
!
!  array arguments
  real &
     yfft1(*),yfft2(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     y1mean,y1sd,y2mean,y2sd
  integer &
     iccov,ifp,inlppc,iym,iymfft,jccov,jnlppc,lagmax, &
     ldsmin,m,nall0,nfft,work
  logical &
     isfft,islong
!
!  local arrays
  real &
     ccov(101,2,2),rhoc(201),rstak(12),sdrhoc(201),stak(12)
  integer &
     ndum(1)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acvff,ccfer,ccfmnf,ccfout,fftlen,ldscmp,setlag, &
     stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),stak(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'c',       'c',       'f',       'f',       ' ',       ' '/

  ierr = 0
  iccov = 101
  inlppc = 1
  iym = n
  jccov = 2
  jnlppc = 1
  lagmax = 1
  iymfft = lyfft
  m = 2
  nfft = n
  isfft = .true.
  islong = .false.

  if (n >= 3) then
!
!  set largest lag value to be used
!
    call setlag(n, lagmax)
!
!  set length of the extended series
!
    call fftlen(n+lagmax, 4, nfft)
  end if

  call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin)

  call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, &
    inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong)
!
!  check whether an error has been detected
!
  if (ierr == 0) then
!
!  set up the work area.
!
    call stkset (ldstak, 4)
    nall0 = stkst(1)

    ifp = 3

    work = stkget(nfft, ifp)

    if (ierr == 0) then
!
!  compute the series acvf and sd
!
      call acvff (yfft1, n, nfft, y1mean, ccov(1,1,1), lagmax, 101, &
         lyfft, stak(work), nfft)
      y1sd = sqrt(ccov(1,1,1) * real ( n ) / real (n-1) )

      call acvff (yfft2, n, nfft, y2mean, ccov(1,2,2), lagmax, 101, &
         lyfft, stak(work), nfft)
      y2sd = sqrt(ccov(1,2,2) * real ( n ) / real (n-1) )
!
!  call routine for main autocorrelation computations.
!
      if (ccov(1,1,1)*ccov(1,2,2)  /=  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)
!
!  call routine to print out autocorrelations
!
      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

    call stkclr(nall0)
  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine ccffs ( ymfft, n, m, iymfft, lagmax, &
  ccov, iccov, jccov, nprt, ldstak )

!*****************************************************************************80
!
!! CCFFS computes multivariate cross-correlations and covariances by FFT.
!
!  Discussion:
!
!    This is the user callable routine for computing the cross
!    correlations and covariances of a multivariate series using the
!    Singleton FFT (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov(iccov, jccov, m)
!        the cross covariance matrix.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer iccov
!        the actual first dimension of the array ccov, as
!        specified in the users program.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer inlppc
!        the actual first dimension of the array nlppc as specifiec
!        in the users program.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on whether printed output is desired.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     logical islong
!        the indicator variable used to designate whether the calling
!        routine has suffix s (islong = true) or not (islong = false)
!     integer iym
!        the actual first dimension of the matrix ym as
!        specified in the users program.
!     integer iymfft
!        the actual first dimension of the matrix ymfft as
!        specified in the users program.
!     integer i2
!        statement function specifying the desired location within ymfft
!     integer i3
!        statement function specifying the desired location within ccov
!     integer j
!        the index of -series 1- in the array ymfft.
!     integer jccov
!        the actual second dimension of the array ccov, as
!        specified in the users program.
!     integer jnlppc
!        the second dimension of the array nlppc as specified
!        in the users program.
!     integer k
!        the index of -series 2- in the array ymfft.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the number of locations in each column of ymfft allowed for
!        the extended series.
!     integer m
!        the number of series being compared, ie the
!        number of columns of data in ymfft.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     integer ndum(1)
!        a dummy dmensioned array.
!     logical newpg
!        an indicator variable used to determine when a new page
!        is appropriate for the output.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nprt
!        the indicator variable used to spedify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is given.
!     integer rhoc
!        the starting location in stak/dstak of the array rhoc.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrhoc
!        the starting location in the work area for sdrhoc.
!     integer work
!        the starging location in dstak of
!        the work vector needed by the fft.
!     integer ymean, ymeanj, ymeank
!        the starting location for the array containing the
!        means of each of the series, and the location in
!        the array for the mean of the jth and kth series,
!        respectively.
!     real ymfft(iymfft, m)
!        the matrix containing the observed time series
!     integer ysd, ysdj, ysdk
!        the starting location for the array containing the
!        standard deviations of each of the series, and the
!        location in the array for the standard deviation of
!        the jth and kth series, respectively.
!
  implicit none

  integer &
     iccov,iymfft,jccov,lagmax,ldstak,m,n,nprt
!
!  array arguments
  real &
     ccov(*),ymfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     i,ifp,inlppc,io,iym,j,jnlppc,k,ldsmin,lyfft,nall0, &
     nfft,rhoc,sdrhoc,work,ymean,ymeanj,ymeank,ysd,ysdj,ysdk
  logical &
     isfft,islong,newpg
!
!  local arrays
  real &
     rstak(12)
  integer &
     ndum(1)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acvff,ccfer,ccfmnf,ccfout,fftlen,ldscmp,stkclr, &
     stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  statement functions
  integer &
     i2,i3
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'c',       'c',       'f',       'f',       's',       ' '/

  i2(i,j) = i + (j-1)*iymfft
  i3(i,j,k) = i + (j-1)*iccov + (k-1)*jccov*iccov

  ierr = 0
  inlppc = iccov
  iym = iymfft
  jnlppc = jccov
  lyfft = iymfft
  m = 2
  isfft = .true.
  islong = .true.

  io = 1
  if (nprt == 0) io = 0
!
!  set length of extended series
!
  if ((n >= 3) .and. (lagmax >= 1)) then
     call fftlen (n+lagmax, 4, nfft)
  else
     nfft = n
  end if

  call ldscmp(3+2*io, 0, 0, 0, 0, 0, 's', &
              2*m+nfft+io*(4*lagmax+2), ldsmin)

  call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, &
    inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong)
!
!  check whether an error has been detected
!
  if (ierr == 0) then
!
!  set up the work area.
!
    call stkset (ldstak, 4)
    nall0 = stkst(1)

    ifp = 3

    ymean = stkget(m, ifp)
    ysd = stkget(m, ifp)
    if (nprt == 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)

    if (ierr == 0) then
!
!  begin loop for computations
!
      newpg = .false.

      do k = 1, m

         ymeank = ymean + k - 1
         ysdk = ysd + k - 1

         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)) * real ( n ) / real (n - 1))

         do j = 1, (k-1)

            ymeanj = ymean + j - 1
            ysdj = ysd + j - 1

            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)
!
!  call routine to print out correlations
!
            if ( nprt /= 0 ) then

              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)

              newpg = .true.

            end if

          end do

      end do

    end if

    call stkclr(nall0)
  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine ccflst ( rhoc, sdrhoc, nlpp12, nlpp21, lagmax, lccov, &
  ncc, ifmiss )

!*****************************************************************************80
!
!! CCFLST lists cross-correlations, standard errors, and summary information.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an index variable.
!     logical ifmiss
!        the indicator variable used to determine
!        whether the input series has missing data or not.
!     integer imax, imin
!        the index values of the first and last observation
!        to be printed per line
!     integer i1
!        an index variable.
!     integer k, k0, k1
!        index variables.
!     integer lag(12)
!        the lag value of the correlation being printed.
!     integer lagmax
!        the largest lag value to be used.
!     integer lagn
!        the number of lag values to be printed per line.
!     integer lccov
!        the number of locations allowed for storing the nlppc.
!     integer ncc
!        the number of cross correlations computed (from -lagmax
!        to +lagmax).
!     integer nlplst(12)
!        the array which contains the values of nlppc to be printed
!        on each line, ordered properly.
!     integer nlpp12(lccov), nlpp21(lccov)
!        the number of lagged product pairs used to compute each
!        ccvf at each lag.
!     integer nperl
!        the number of values to be printed per line.
!     real rhoc(ncc)
!        the array in which the autocorrelations or partial
!        autocorrelations will be passed to this routine.
!     real rlst(12)
!        the array which contains the values of rho to be printed
!        on each line, ordered properly.
!     real sdrhoc(ncc)
!        the array in which the standard errors of the autocorrelations
!        are stored
!     real sdrlst(12)
!        the array which contains the values of sdrho to be printed
!        on each line, ordered properly.
!
  implicit none

  integer &
     lagmax,lccov,ncc
  logical &
     ifmiss
!
!  array arguments
  real &
     rhoc(ncc),sdrhoc(ncc)
  integer &
     nlpp12(lccov),nlpp21(lccov)
!
!
  real &
     fplm
  integer &
     i,i1,imax,imin,k,k0,k1,lagn,nperl
!
!  local arrays
  real &
     rlst(12),sdrlst(12)
  integer &
     lag(12),nlplst(12)

  nperl = 12

  k0 = lagmax + 1

  lagn = mod(lagmax, nperl)
  if (lagn == 0) lagn = nperl
  i1 = lagn + 1

  do i = i1, k0, nperl
     do k = 1, lagn
        lag(k) = i - k0 - k
        k1 = i - k
        rlst(k) = rhoc(k1)
        sdrlst(k) = sdrhoc(k1)
        if ( ifmiss ) then
          k1 = k0 - k1
          nlplst(k) = nlpp21(k1+1)
        end if
     end do
     write ( *, 1000) (lag(k), k = 1, lagn)
     write ( *, 1001) (rlst(k), k = 1, lagn)
     write ( *, 1002) (sdrlst(k), k = 1, lagn)
     if (ifmiss) write ( *, 1003) (nlplst(k), k = 1, lagn)
     lagn = nperl
  end do

  lag(1) = 0
  write ( *, 1000) lag(1)
  write ( *, 1001) rhoc(k0)
  write ( *, 1002) sdrhoc(k0)
  if (ifmiss) write ( *, 1003) nlpp12(1)

  do i = 1, lagmax, nperl

     imin = i + k0
     imax = min(imin + nperl - 1, 2*lagmax+1)
     lagn = imax - imin + 1

     do k = 1, lagn
        lag(k) = i - 1 + k
     end do

     write ( *, 1000) (lag(k), k = 1, lagn)
     write ( *, 1001) (rhoc(k), k = imin, imax)
     write ( *, 1002) (sdrhoc(k), k = imin, imax)

     if ( ifmiss) then
       imin = i
       imax = min(i + nperl - 1, lagmax)
       write ( *,1003) (nlpp12(k+1), k=imin,imax)
    end if

  end do

  fplm = huge ( fplm )

  if (sdrhoc(1) == fplm .or. sdrhoc(2*lagmax+1) == fplm) &
     write ( *, 1004) fplm

  return

 1000 format(/' lag               ', 12(1x, i6))
 1001 format( ' ccf               ', 12(2x, f5.2))
 1002 format( ' standard error    ', 12(2x, f5.2))
 1003 format( ' no. of obs. used  ', 12(1x, i6))
 1004 format(///5x, f5.2, ' indicates value could not be computed', &
     ' due to missing data.')
end
subroutine ccfm ( y1, y1miss, y2, y2miss, n )

!*****************************************************************************80
!
!! CCFM computes cross-correlation of two series with missing data.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov(101, 2, 2)
!        the array used for the ccvf estimates.
!     integer iccov
!        the actual first dimension of the array ccov, as
!        specified in the users program.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer inlppc
!        the actual first dimension of the array nlppc as specifiec
!        in the users program.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     logical islong
!        the indicator variable used to designate whether the calling
!        routine has suffix s (islong = true) or not (islong = false)
!     integer iym
!        the actual first dimension of the matrix ym as
!        specified in the users program.
!     integer iymfft
!        the actual first dimension of the matrix ymfft as
!        specified in the users program.
!     integer jccov
!        the actual second dimension of the array ccov, as
!        specified in the users program.
!     integer jnlppc
!        the second dimension of the array nlppc as specified
!        in the users program.
!     integer lagmax
!        the number of autocorrelations desired.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lglst1, lglst2
!        the lag value of the last acvf which could be computed
!        for series 1 and 2, respectively, before missing data
!        caused a missing acvf.
!     integer lyfft
!        the length of the vector yfft.
!     integer m
!        the number of series being compared, ie the
!        number of columns of data in ym.
!     integer n
!        the integer number of observations in each series
!     integer nfft
!        the number of observations in the extended series.
!     integer nlppc(101, 2, 2)
!        the number of lagged product pairs used to compute the ccvf.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nused1, nused2
!        the number of active (non missing) observations in series
!        1 and 2, respectively.
!     real rhoc(201)
!        the ccf estimates.
!     real sdrhoc(201)
!        the array containing the sd of the ccfm.
!     real y1(n), y1mean, y1miss, y1sd
!        the first series, and its mean, missing value code and
!        standard deviation.
!     real y2(n), y2mean, y2miss, y2sd
!        the second series, and its mean, missing value code and
!        standard deviation.
!
  implicit none

  real &
     y1miss,y2miss
  integer &
     n
!
!  array arguments
  real &
     y1(*),y2(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     y1mean,y1sd,y2mean,y2sd
  integer &
     iccov,inlppc,iym,iymfft,jccov,jnlppc,lagmax,ldsmin, &
     ldstak,lglst1,lglst2,lyfft,m,nfft,nused1,nused2
  logical &
     isfft,islong
!
!  local arrays
  real &
     ccov(101,2,2),rhoc(201),sdrhoc(201)
  integer &
     nlppc(101,2,2)
  character &
     nmsub(6)*1
!
!  external subroutines
  external acvfm,ccfer,ccfmnm,ccfout,setlag
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'c',       'c',       'f',       'm',       ' ',       ' '/

  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.
!
!  call error checking routines
!
  call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, &
    inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong)
!
!  check whether an error has been detected
!
  if (ierr == 0) then
!
!  set the maximum lag value to be used.
!
    call setlag (n, lagmax)
!
!  compute the series acvf and sd
!
    call acvfm (y1, y1miss, n, y1mean, ccov(1,1,1), lagmax, lglst1, &
       nlppc(1,1,1), 101)

    nused1 = nlppc(1,1,1)
    y1sd = sqrt(ccov(1,1,1) * real ( n ) / real (nused1-1) )

    call acvfm (y2, y2miss, n, y2mean, ccov(1,2,2), lagmax, lglst2, &
       nlppc(1,2,2), 101)

    nused2 = nlppc(1,2,2)
    y2sd = sqrt(ccov(1,2,2) * real ( n ) / real (nused2-1) )
!
!  call routine for main autocorrelation computations.
!
    if (ccov(1,1,1)*ccov(1,2,2)  /=  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))
!
!  call routine to print out autocorrelations
!
    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

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine ccfmn ( y1, y2, n, lagmax, ncc, ccov11, ccov22, ccov12, &
  ccov21, lccov, y1mean, y2mean, rhoc, sdrhoc, nprt )

!*****************************************************************************80
!
!! CCFMN is the main routine for cross-correlations.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov11(lccov)
!        the array in which the autocovariance function estimates
!        for the first series is stored.
!     real ccov12(lccov), ccov21(lccov)
!        the arrays in which the cross covariance function
!        estimates for the first series lagged behind the second
!        and visa versa, are stored.
!     real ccov22(lccov)
!        the array in which the autocovariance function estimates
!        for the second series is stored.
!     real fac
!        the inverse of the square root of the product of the
!        autocovariances at lag zero.
!     integer i
!        the indexing variable for the lag value.
!     integer  im, ip, i0
!        the locations in the ccf related arrays
!        of the lag -i, i, and 0, respectively.
!     integer lagmax
!        the maximum lag value at which the ccvf is to be computed.
!     integer lccov
!        the dimension of the covariance related arrays.
!     integer n
!        the integer number of observations in the series
!     integer ncc
!        the number of ccf computed.
!     integer nprt
!        the indicator variable used to control computations needed
!        only for printed output.
!     real rhoc(ncc)
!        the array in which the cross correlations are stored
!     real sdrhoc(ncc)
!        the array containing the std. errors of the cross correlations.
!        are stored
!     real y1(n), y1mean
!        the first series, and its mean.
!     real y2(n), y2mean
!        the second series, and its mean.
!
  implicit none

  real &
     y1mean,y2mean
  integer &
     lagmax,lccov,n,ncc,nprt
!
!  array arguments
  real &
     ccov11(lccov),ccov12(lccov),ccov21(lccov),ccov22(lccov), &
     rhoc(ncc),sdrhoc(ncc),y1(n),y2(n)
!
!
  real &
     fac
  integer &
     i,i0,im,ip
!
!  external subroutines
  external ccfsd,ccvf
!
!     compute the cross correlations.
!
  call ccvf(y1, y2, n, lagmax, y1mean, y2mean, ccov12, ccov21, &
     lccov)

  if (nprt == 0 .or. ccov11(1)*ccov22(1) == 0.0e0) return

  fac = 1.0e0 / sqrt(ccov11(1) * ccov22(1))

  i0 = lagmax + 1
  rhoc(i0) = ccov12(1) * fac
  do i = 1, lagmax
     ip = i0 + i
     rhoc(ip) = ccov12(i+1) * fac
     im = i0 - i
     rhoc(im) = ccov21(i+1) * fac
  end do
!
!  compute standard error of the crosscorrelations.
!
  call ccfsd ( ccov11, ccov22, sdrhoc, lagmax, ncc, n, lccov )

  return
end
subroutine ccfmnf ( y1, y2, n, nfft, lagmax, ncc, ccov11, ccov22, &
  ccov12, ccov21, lccov, rhoc, sdrhoc, nprt, lyfft, work, lwork )

!*****************************************************************************80
!
!! CCFMNF is the main routine for cross-correlations using an FFT.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov11(lccov)
!        the array in which the autocovariance function estimates
!        for the first series is stored.
!     real ccov12(lccov), ccov21(lccov)
!        the arrays in which the cross covariance function
!        estimates for the first series lagged behind the second
!        and visa versa, are stored.
!     real ccov22(lccov)
!        the array in which the autocovariance function estimates
!        for the second series is stored.
!     real fac
!        the inverse of the square root of the product of the
!        autocovariances at lag zero.
!     integer i
!        the indexing variable for the lag value.
!     integer  im, ip, i0
!        the locations in the ccf related arrays
!        of the lag -i, i, and 0, respectively.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lccov
!        the dimension of the covarance arrays.
!     integer lwork
!        the dimension of the work array.
!     integer lyfft
!        the dimension of the data arrays.
!     integer n
!        the integer number of observations in the series
!     integer ncc
!        the number of cross correlations computed.
!     integer nfft
!        the number of observations in the extended series.
!     integer nprt
!        the indicator variable used to control computations needed
!        only for printed output.
!     real rhoc(ncc)
!        the array in which the cross correlations are stored
!     real sdrhoc(ncc)
!        the array containing the std. errors of the cross correlations.
!        are stored.
!     real work(lwork)
!        the work array.
!     real y1(lyfft), y2(lyfft)
!        the vectors containing the observed series
!
  implicit none

  integer &
     lagmax,lccov,lwork,lyfft,n,ncc,nfft,nprt
!
!  array arguments
  real &
     ccov11(lccov),ccov12(lccov),ccov21(lccov),ccov22(lccov), &
     rhoc(ncc),sdrhoc(ncc),work(lwork),y1(lyfft),y2(lyfft)
!
!
  real &
     fac
  integer &
     i,i0,im,ip
!
!  external subroutines
  external ccfsd,ccvff
!
!  compute the cross correlations.
!
  call ccvff (y1, y2, n, nfft, lagmax, ccov12, ccov21, lccov, lyfft, &
     work, lwork)

  if (nprt == 0 .or. ccov11(1)*ccov22(1) == 0.0e0) return

  fac = 1.0e0 / sqrt(ccov11(1) * ccov22(1))

  i0 = lagmax + 1
  rhoc(i0) = ccov12(1) * fac
  do i = 1, lagmax
     ip = i0 + i
     rhoc(ip) = ccov12(i+1) * fac
     im = i0 - i
     rhoc(im) = ccov21(i+1) * fac
  end do
!
!  compute standard error of the crosscorrelations.
!
  call ccfsd (ccov11, ccov22, sdrhoc, lagmax, ncc, n, lccov)

  return
end
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 )

!*****************************************************************************80
!
!! CCFMNM is the main routine for cross-correlations with missing data.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov11(iccov), ccov12(iccov)
!     real ccov21(iccov), ccov22(iccov)
!        the array containing the autocovariance and cross covariance
!        estimates for series 1 and 2.
!     real fac
!        the inverse of the square root of the product of the
!        autocovariances at lag zero.
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        the indexing variable for the lag.
!     integer iccov
!        the dimension of the covariance vectors.
!     integer im
!        the locations in the various ccf related arrays of lag -i.
!     integer inlppc
!        the dimension of the lagged product pair count vectors.
!     integer ip
!        the location if the various ccf related arrays of lag i.
!     integer i0
!        the location if the various ccf related arrays of lag 0.
!     integer laglst
!        the last lag before missing data caused the acvf of either
!        series 1 or 2 not to be computed.
!     integer lagmax
!        the maximum lag value to be used.
!     integer n
!        the integer number of observations in the series
!     integer ncc
!        the number of cross correlations to be computed.
!     integer nlpp11(inlppc), nlpp12(inlppc), nlpp21(inlppc),
!    +        nlpp22(inlppc)
!        the numbers of lagged product pairs used to compute
!        the autocovariance and cross covariance estimates.
!     integer nprt
!        the variable used to control printed output.
!     real rhoc(ncc)
!        the array in which the auto and cross correlations are stored
!     real sdrhoc(ncc)
!        the array containing the std. errors of the cross correlations.
!        are stored
!     real y1(n), y1mean, y1miss
!        the first series, and its mean, and missing value code.
!     real y2(n), y2mean, y2miss
!        the second series, and its mean, and missing value code.
!
  implicit none

  real &
     y1mean,y1miss,y2mean,y2miss
  integer &
     iccov,inlppc,laglst,lagmax,n,ncc,nprt
!
!  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)
!
!
  real &
     fac,fplm
  integer &
     i,i0,im,ip
!
!  external subroutines
  external ccfsdm,ccvfm
!
  fplm = huge ( fplm )
!
!  Compute autocorrelations and standard deviation of the series.
!
  call ccvfm ( y1, y1miss, y2, y2miss, n, lagmax, y1mean, y2mean, &
     ccov12, ccov21, iccov, nlpp12, nlpp21 )

  if (nprt == 0 .or. nlpp11(1) == 0) return
  if (ccov11(1) *ccov22(1) == 0.0e0) return

  fac = 1.0e0 / sqrt(ccov11(1) * ccov22(1))

  i0 = lagmax + 1
  rhoc(i0) = fplm
  if (nlpp12(1) >= 1) rhoc(i0) = ccov12(1) * fac

  do i = 1, lagmax
     ip = i0 + i
     rhoc(ip) = fplm
     if (nlpp12(i+1) >= 1) rhoc(ip) = ccov12(i+1) * fac
     im = i0 - i
     rhoc(im) = fplm
     if (nlpp21(i+1) >= 1) rhoc(im) = ccov21(i+1) * fac
  end do
!
!  compute standard error of autocorrelations.
!
  call ccfsdm (ccov11, ccov22, sdrhoc, lagmax, ncc, laglst, n, &
     nlpp12, nlpp21, iccov, inlppc)

  return
end
subroutine ccfms ( ym, ymmiss, n, m, iym, lagmax, ccov, &
  cmiss, iccov, jccov, nlppc, inlppc, jnlppc, nprt, ldstak )

!*****************************************************************************80
!
!! CCFMS is a user routine for multivariate cross-correlations.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov(iccov, jccov, m)
!        the cross covariance matrix.
!     real cmiss
!        the missing value code for the ccvf estimates.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fplm
!        the floating point largest magnitude.
!     integer iccov
!        the actual first dimension of the array ccov, as
!        specified in the users program.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer inlppc
!        the actual first dimension of the array nlppc as specifiec
!        in the users program.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on whether printed output is desired.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     logical islong
!        the indicator variable used to designate whether the calling
!        routine has suffix s (islong = true) or not (islong = false)
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer iym
!        the actual first dimension of the matrix ym as
!        specified in the users program.
!     integer iymfft
!        the actual first dimension of the matrix ymfft as
!        specified in the users program.
!     integer i2
!        statement function specifying the desired location within ym
!     integer i3c
!        statement function specifying the desired location within ccov
!     integer i3n
!        statement function specifying the desired location within nlppc
!     integer j
!        the index of -series 1- in the array ym.
!     integer jccov
!        the actual second dimension of the array ccov, as
!        specified in the users program.
!     integer jnlppc
!        the second dimension of the array nlppc as specified
!        in the users program.
!     integer k
!        the index of -series 2- in the array ym.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lglst, lglstj, lglstk
!        the starting location in istak for the array lglst,
!        and the locations in lglst in ehich the number of the
!        lag of the last acvf which could be computed for series
!        j and k, respectively, before a missng acvf (due to missing
!        data).
!     integer lyfft
!        the length of the vector yfft.
!     integer m
!        the number of series being compared, ie the
!        number of columns of data in ym.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     logical newpg
!        an indicator variable used to determine when a new page
!        is appropriate for the output.
!     integer nfft
!        the number of observations in the extended series.
!     integer nlppc(inlppc, jnlppc, m)
!        the array containing the number of lagged product pairs
!        used to compute each acvf estimate.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nprt
!        the indicator variable used to spedify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is given.
!     integer rhoc
!        the starting location in dstak of the array rhoc.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrhoc
!        the starting location in the work area for sdrhoc.
!     real ym(iym, m)
!        the matrix containing the observed time series
!     integer ymean, ymeanj, ymeank
!        the starting location for the array containing the
!        means of each of the series, and the location in
!        the array for the mean of the jth and kth series,
!        respectively.
!     real ymmiss(m)
!        the missing value codes for each of the series in ym.
!     integer ysd, ysdj, ysdk
!        the starting location for the array containing the
!        standard deviations of each of the series, and the
!        location in the array for the standard deviation of
!        the jth and kth series, respectively.
!
  implicit none

  real &
     cmiss
  integer &
     iccov,inlppc,iym,jccov,jnlppc,lagmax,ldstak,m,n,nprt
!
!  array arguments
  real &
     ccov(*),ym(*),ymmiss(*)
  integer &
     nlppc(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     fplm
  integer &
     i,ifp,io,iymfft,j,k,ldsmin,lglst,lglstj,lglstk,lyfft, &
     nall0,nfft,rhoc,sdrhoc,ymean,ymeanj,ymeank,ysd,ysdj,ysdk
  logical &
     isfft,islong,newpg
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acvfm,ccfer,ccfmnm,ccfout,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  statement functions
  integer &
     i2,i3c,i3n
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'c',       'c',       'f',       'm',       's',       ' '/

  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

  ierr = 0
  lyfft = n + lagmax
  iymfft = lyfft
  nfft = n
  isfft = .false.
  islong = .true.

  io = 1
  if (nprt == 0) io = 0

  call ldscmp(3+2*io, 0, m, 0, 0, 0, 's', &
              2*m+io*(4*lagmax+2), ldsmin)

  call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, &
    inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong)
!
!  check whether an error has been detected
!
  if (ierr == 0) then

    fplm = huge ( fplm )
!
!  set up the work area.
!
    call stkset (ldstak, 4)
    nall0 = stkst(1)

    ifp = 3

    ymean = stkget(m, ifp)
    ysd = stkget(m, ifp)
    lglst = stkget(m, 2)
    if (nprt == 0) then
      rhoc = ysd
      sdrhoc = ysd
    else
      rhoc = stkget(2*lagmax+1, ifp)
      sdrhoc = stkget(2*lagmax+1, ifp)
    end if

    if (ierr == 0) then
!
!  begin loop for computations
!
      newpg = .false.

      do k = 1, m

         ymeank = ymean + k - 1
         ysdk = ysd + k - 1
         lglstk = lglst + k - 1

         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)) * real ( n ) / real (n - 1))

         do j = 1, (k-1)

            ymeanj = ymean + j - 1
            ysdj = ysd + j - 1
            lglstj = lglst + j - 1

            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)))

            if (nprt /= 0) then
!
!  Call routine to print out correlations
!
            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)

            newpg = .true.

            end if

          end do
       end do

      cmiss = fplm
    end if

    call stkclr(nall0)
  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine ccfout ( j, ymeanj, ysdj, nj, nusedj, k, ymeank, ysdk, &
  nk, nusedk, lagmax, ncc, rhoc, sdrhoc, ifmiss, nlpp12, &
  nlpp21, lccov, ymissj, ymissk, newpg )

!*****************************************************************************80
!
!! CCFOUT prints cross-correlations and standard errors.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real fplm
!        the floating point largest magnitude.
!     logical ifmiss
!        the indicator variable used to determine
!        whether the input series has missing data or not.
!     integer isym(1)
!        a dummy array.
!     integer j, k
!        the subscript values of the two series being compared.
!     integer lagmax
!        the largest lag value to be used.
!     integer lccov
!        the number of locations allowed for storing the nlppc.
!     integer ncc
!        the number of cross correlations computed (from -lagmax
!        to +lagmax).
!     logical newpg
!        an indicator variable used to determine if the output should
!        start on a new page.
!     integer nj, nk
!        the integer number of observations in each series
!     integer nlpp12(lccov), nlpp21(lccov)
!        the number of lagged product pairs used to compute each
!        ccvf at each lag.
!     integer nmissj, nmissk
!        the number of missing values in each series.
!     integer nusedj, nusedk
!        the active number of observations in each series.
!     real pmissj, pmissk
!        the percent of missing observations.
!     real rhoc(ncc)
!        the array in which the cross correlations are stored
!     real sdrhoc(ncc)
!        the array in which the standard errors of the autocorrelations
!        are stored
!     real ymeanj, ymeank
!        the mean of each of the series.
!     real ymissj, ymissk
!        the missing value code for each series.
!     real ymmiss(1)
!        the missing value code for the cross correlations.
!     real ysdj, ysdk
!        the standard deviaion of each series.
!
  implicit none

  real &
     ymeanj,ymeank,ymissj,ymissk,ysdj,ysdk
  integer &
     j,k,lagmax,lccov,ncc,nj,nk,nusedj,nusedk
  logical &
     ifmiss,newpg
!
!  array arguments
  real &
     rhoc(*),sdrhoc(*)
  integer &
     nlpp12(*),nlpp21(*)

  real &
     fplm,pmissj,pmissk
  integer &
     nmissj,nmissk
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
!
!  external subroutines
  external ccflst,versp,vpmn

  fplm = huge ( fplm )

  ymmiss(1) = fplm
!
!  Print summary information.
!
  if (newpg) write ( *, 1004)
  call versp (.true.)
  write ( *, 1005)

  write ( *, 1000) j, k, ymeanj, ymeank, ysdj, ysdk, nj, nk

  if ( ifmiss ) then
    nmissj = nj - nusedj
    pmissj = 100.0e0 * real ( nmissj ) / real ( nj )
    nmissk = nk - nusedk
    pmissk = 100.0e0 * real ( nmissk ) / real ( nk )
    write ( *, 1003) nmissj, nmissk, pmissj, pmissk
  end if

   write ( *, 1006) lagmax
  if (ifmiss) write ( *, 1007) ymissj, ymissk

  if ( ysdj <= 0.0e0 .or. ysdk <= 0.0e0) then
    write ( *, 1008) j, k
    return
  end if
!
!  Print ccf information.
!
  write ( *, 1002)
  write ( *, 1001) j, k
  call ccflst (rhoc, sdrhoc, nlpp12, nlpp21, lagmax, lccov, ncc, &
     ifmiss)
!
!  Plot ccf information.
!
  write ( *, 1004)
  call versp (.true.)
  write ( *, 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

 1000 format(/ 42x, 'series ', i2, 5x, 'series ', i2// &
     ' average of the series                 = ', 2g14.7/ &
     ' standard deviation of the series      = ', 2g14.7/ &
     ' number of time points                 = ', 2(i10, 4x))
 1001 format (' cross correlation function estimate (ccf)'// &
     ' ccf correlates series ', i2, ' at time t with series ', i2, &
     ' at time t + k.'/ &
     5x, '(if peak correlation occures at positive (negative) lag'/ &
     8x, 'then series 1 leads (lags) series 2)')
 1002 format(//)
 1003 format ( &
     ' number of missing observations        = ', 2(i10, 4x)/ &
     ' percentage of observations missing    = ', 2(f10.4, 4x))
 1004 format ('1')
 1005 format ( ' cross correlation analysis')
 1006 format(/ &
     ' largest lag value to be used          = ', i10)
 1007 format( &
     ' missing value code                    = ', 2g14.7)
 1008 format (//' cross correlations between series ', i2, ' and ', &
     i2, ' could not be computed'/ &
     ' because the lag zero autocovariance of one or both of'/ &
     ' the series is zero.')
end
subroutine ccfsd ( ccov11, ccov22, sdrhoc, lagmax, ncc, n, iccov )

!*****************************************************************************80
!
!! CCFSD is the main routine for computing standard error of cross-correlations.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov11(iccov), ccov22(iccov)
!        the arrays in which the autocovariances are stored
!     real div
!        the square root of the product of the autocovariance
!        function values at lag zero.
!     integer iccov
!        the dimension of the acvf arrays.
!     integer ilast
!        the last lag at which the standard error is to be computed.
!     integer k
!        an index varialbe.
!     integer km, kp, k0
!        the locations in the arrays -rhoc- and -sdrhoc-
!        of the lag -k, k and 0, respectively.
!     integer lagmax
!        the maximum lag value used.
!     integer n
!        the integer number of observations in the series
!     integer ncc
!        the number of ccf computed.
!     real sdrhoc(ncc)
!        the array in which the standard errors of the cross correlation
!        are stored
!     real sum
!         a summing variable.
!
  implicit none

  integer &
     iccov,lagmax,n,ncc
!
!  array arguments
  real &
     ccov11(iccov),ccov22(iccov),sdrhoc(ncc)

  real &
     div,sum
  integer &
     i,ilast,k,k0,km,kp

  k0 = lagmax + 1

  div = ccov11(1) * ccov22(1)

  sum = dot_product ( ccov11(2:lagmax+1), ccov22(2:lagmax+1) )
  sum = sum / div
  sdrhoc(k0) = sqrt( real ( n ) + 2.0e0 * sum) / real ( n )

  do k = 1, lagmax
     sum = 0.0e0
     ilast = min(lagmax, n-lagmax)
     do i = 1, ilast
        sum = sum + real(n-k-i) * ccov11(i+1)*ccov22(i+1)
     end do
     sum = sum / div
     km = k0 - k
     sdrhoc(km) = sqrt( real(n - k) + 2.0e0 * sum) / real ( n )

     kp = k0 + k
     sdrhoc(kp) = sdrhoc(km)

  end do

  return
end
subroutine ccfsdm ( ccov11, ccov22, sdrhoc, lagmax, ncc, laglst, n, &
  nlpp12, nlpp21, iccov, inlppc )

!*****************************************************************************80
!
!! CCFSDM: standard error of cross-correlations with missing data.
!
!  Modified:
!
!    19 May 2007
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov11(iccov), ccov22(iccov)
!        the arrays in which the autocovariances are stored.
!     real div
!        the square root of the product of the autocovariance
!        function values at lag zero.
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        indexing variables.
!     integer iccov
!        the dimension of the covariance vectors.
!     integer ilast
!        the last lag at which the standard errors are to be computed.
!     integer inlppc
!        the dimension of the lagged product pair count vectors.
!     integer k
!        indexing variables.
!     integer km, kp, k0
!        the locations in the arrays -rhoc- and -sdrhoc-
!        of the lag -k, k and 0, respectively.
!     integer laglst
!        the last autocorrelation computed before a missing
!        autocorrelation was incountered in either series.
!     integer lagmax
!        the maximum lag value used.
!     integer n
!        the integer number of observations in the series
!     integer ncc
!       the number of cross correlations computed.
!     integer nlpp12(inlppc), nlpp21(inlppc)
!        the arrays in which the number of observations used to
!        compute each cross correlation are stored.
!     real sdrhoc(ncc)
!        the array in which the standard errors of the cross correlation
!        are stored
!     real sum
!         a summing variable.
!
  implicit none

  integer &
     iccov,inlppc,laglst,lagmax,n,ncc
!
!  array arguments
  real &
     ccov11(iccov),ccov22(iccov),sdrhoc(ncc)
  integer &
     nlpp12(inlppc),nlpp21(inlppc)

  real &
     div,fplm,sum
  integer &
     i,ilast,k,k0,km,kp

  fplm = huge ( fplm )

  div = ccov11(1) * ccov22(1)

  k0 = lagmax + 1

  sum = dot_product ( ccov11(2:laglst+1), ccov22(2:laglst+1) )
  sum = sum / div
  sdrhoc(k0) = fplm

  if ( 1 <= nlpp12(1) ) then
    sdrhoc(k0) = sqrt( real ( n ) + 2.0e0 * sum) / real ( nlpp12(1) )
  end if

  do k = 1, lagmax
     sum = 0.0e0
     ilast = min(laglst, n-laglst)
     do i = 1, ilast
        sum = sum + real (n-k-i) * ccov11(i+1) * ccov22(i+1)
     end do
     sum = sum / div
     km = k0 - k
     sdrhoc(km) = fplm
     if (nlpp21(k+1)  >=  1) sdrhoc(km) = &
        sqrt(real (n - k) + 2.0e0 * sum) * real (n - k) &
        / real (n * nlpp21(k+1))

     kp = k0 + k
     sdrhoc(kp) = fplm
     if (nlpp12(k+1)  >=  1) sdrhoc(kp) = &
        sqrt( real (n - k) + 2.0e0 * sum) * real (n - k) &
        / real ( n * nlpp12(k+1) )
  end do

  return
end
subroutine ccfs ( ym, n, m, iym, lagmax, ccov, iccov, jccov, &
  nprt, ldstak )

!*****************************************************************************80
!
!! CCFS is the user routine for multivariate cross-correlations.
!
!  Discussion:
!
!    This is the user callable routine for computing the cross
!    correlations and covariances of a multivariate series (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov(iccov, jccov, m)
!        the cross covariance matrix.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer iccov
!        the actual first dimension of the array ccov, as
!        specified in the users program.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer inlppc
!        the actual first dimension of the array nlppc as specifiec
!        in the users program.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on whether printed output is desired.
!     logical isfft
!        the indicator variable used to designate whether the calling
!        routine has suffix f (isfft = true) or not (isfft = false)
!     logical islong
!        the indicator variable used to designate whether the calling
!        routine has suffix s (islong = true) or not (islong = false)
!     integer iym
!        the actual first dimension of the matrix ym as
!        specified in the users program.
!     integer iymfft
!        the actual first dimension of the matrix ymfft as
!        specified in the users program.
!     integer i2
!        statement function specifying the desired location within ym
!     integer i3
!        statement function specifying the desired location within ccov
!     integer j
!        the index of -series 1- in the array ym.
!     integer jccov
!        the actual second dimension of the array ccov, as
!        specified in the users program.
!     integer jnlppc
!        the second dimension of the array nlppc as specified
!        in the users program.
!     integer k
!        the index of -series 2- in the array ym.
!     integer lagmax
!        the maximum lag value requested.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lyfft
!        the length of the vector yfft.
!     integer m
!        the number of series being compared, ie the
!        number of columns of data in ym.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of outstanding stack allocations
!     integer ndum(1)
!        a dummy dimensioned variable.
!     logical newpg
!        an indicator variable used to determine when a new page
!        is appropriate for the output.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutine.
!     integer nprt
!        the indicator variable used to spedify whether or not
!        printed output is to be given, where if the value of
!        nprt is zero, no output is given.
!     integer rhoc
!        the starting location in dstak of the array rhoc.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer sdrhoc
!        the starting location in the work area for sdrhoc.
!     real ym(iym, m)
!        the matrix containing the observed time series
!     integer ymean, ymeanj, ymeank
!        the starting location for the array containing the
!        means of each of the series, and the location in
!        the array for the mean of the jth and kth series,
!        respectively.
!     integer ysd, ysdj, ysdk
!        the starting location for the array containing the
!        standard deviations of each of the series, and the
!        location in the array for the standard deviation of
!        the jth and kth series, respectively.
!
  implicit none

  integer &
     iccov,iym,jccov,lagmax,ldstak,m,n,nprt
!
!  array arguments
  real &
     ccov(*),ym(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     i,ifp,inlppc,io,iymfft,j,jnlppc,k,ldsmin,lyfft,nall0, &
     nfft,rhoc,sdrhoc,ymean,ymeanj,ymeank,ysd,ysdj,ysdk
  logical &
     isfft,islong,newpg
!
!  local arrays
  real &
     rstak(12)
  integer &
     ndum(1)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acvf,ccfer,ccfmn,ccfout,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  statement functions
  integer &
     i2,i3
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!  set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'c',       'c',       'f',       's',       ' ',       ' '/

  i2(i,j) = i + (j-1)*iym
  i3(i,j,k) = i + (j-1)*iccov + (k-1)*jccov*iccov

  ierr = 0
  inlppc = iccov
  jnlppc = jccov
  lyfft = n + lagmax
  iymfft = iym
  nfft = n
  isfft = .false.
  islong = .true.

  io = 1
  if (nprt == 0) io = 0

  call ldscmp(2+2*io, 0, 0, 0, 0, 0, 's', &
              2*m+io*(4*lagmax+2), ldsmin)

  call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, &
    inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong)
!
!  check whether an error has been detected
!
  if (ierr == 0) then
!
!  set up the work area.
!
    call stkset (ldstak, 4)
    nall0 = stkst(1)

    ifp = 3

    ymean = stkget(m, ifp)
    ysd = stkget(m, ifp)
    if (nprt == 0) then
      rhoc = ysd
      sdrhoc = ysd
    else
      rhoc = stkget(2*lagmax+1, ifp)
      sdrhoc = stkget(2*lagmax+1, ifp)
    end if

    if (ierr == 0) then
!
!  begin loop for computations
!
      newpg = .false.

      do k = 1, m

         ymeank = ymean + k - 1
         ysdk = ysd + k - 1

         call acvf (ym(i2(1,k)), n, rstak(ymeank), &
                    ccov(i3(1,k,k)), lagmax, iccov)
         rstak(ysdk) = sqrt(ccov(i3(1,k,k)) * real ( n ) / real ( n - 1 ) )

         do j = 1, (k-1)

            ymeanj = ymean + j - 1
            ysdj = ysd + j - 1

            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)

            if (nprt /= 0) then
!
!  call routine to print out correlations
!
            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)

            newpg = .true.

           end if

        end do
      end do
    end if

    call stkclr(nall0)
  end if

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine ccfxp ( store, lagmax, m, ccov, iccov, jccov, miss, &
  nlppc, inlppc, jnlppc, cmiss )

!*****************************************************************************80
!
!! CCFXP lists results for the time series cross-correlation routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccf(16)
!        an array used for printing the ccf.
!     real ccov(iccov,jccov,m)
!        the cross covariance array.
!     real cmiss
!        the missing value code for the returned ccvf estimates
!        (vector ccov).
!     integer i
!        an indexing variable.
!     integer iccov
!        the first dimension of the array ccov.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!     integer inlppc
!        the first dimension of the array nlppc.
!     integer j
!        an indexing variable.
!     integer jccov, jnlppc
!        the second dimensions of the arrays ccov and nlppc,
!        respectively.
!     integer k
!        an indexing variable.
!     integer l1
!        an index variable.
!     integer lag
!        the lag value at which the data is being printed.
!     integer lagmax
!        the maximum lag value requested.
!     integer m
!        the number of series in the multivariate time series ym.
!     logical miss
!        the value indicating whether the analysis included missing
!        data (true) or not (false).
!     integer nlppc(inlppc,jnlppc,m)
!        the array containing the number of lagged product pairs
!        used to compute each ccvf estimate.
!     logical store
!        the value indicating whether the results were returned
!        to the user (true) or not (false).
!
  implicit none

  real &
     cmiss
  integer &
     iccov,inlppc,jccov,jnlppc,lagmax,m
  logical &
     miss,store
!
!  array arguments
  real &
     ccov(iccov,jccov,*)
  integer &
     nlppc(inlppc,jnlppc,*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,j,k,l,l1,lag
!
!  local arrays
  real &
     ccf(16)
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  common blocks
  common /errchk/ierr

  write ( *, 1000) ierr

  if (ierr /= 0) then
    return
  end if
!
!  Check for stored results
!
  if ( .not. store ) then
    return
  end if
!
!  print heading for ccvf
!
  write ( *, 1010)
  write ( *, 1040) ((j,k, k=1,m), j=1,m)
!
!  print cross covariances
!
  lag = 0
  write ( *, 1060) lag, ((ccov(1,j,k), k=1,m), j=1,m)
  do lag = 1, lagmax
     write ( *, 1060) lag, ((ccov(lag+1,j,k), k=1,m), j=1,m)
  end do
!
!  print heading for ccf
!
  write ( *, 1020)
  write ( *, 1040) ((j,k, k=1,m), j=1,m)
!
!  print cross correlations
!
  lag = 0
  i = 0
  do j = 1, m
     do k = 1, m
        i = i + 1
        ccf(i) = ccov(1,j,k) / sqrt(ccov(1,j,j)*ccov(1,k,k))
     end do
  end do

  write ( *, 1060) lag, (ccf(l), l=1,i)

  do lag = 1, lagmax
     i = 0
     do j = 1, m
        do k = 1, m
           i = i + 1

           if ( miss .and. mvchk ( ccov(lag+1,j,k), cmiss ) ) then
             ccf(i) = cmiss
           else
             ccf(i) = ccov(lag+1,j,k) / sqrt(ccov(1,j,j)*ccov(1,k,k))
           end if

        end do
     end do
     write ( *, 1060) lag, (ccf(l1), l1=1,i)
  end do
!
!  Check for missing values
!
  if ( .not. miss ) then
    return
  end if
!
!  print heading for numbers of lagged product pairs
!
  write ( *, 1030)
  write ( *, 1040) ((j,k, k=1,m), j=1,m)
!
!  print numbers of lagged product pairs for each ccvf
!
  lag = 0
  write ( *, 1070) lag, ((nlppc(1,j,k), k=1,m), j=1,m)
  do lag = 1, lagmax
     write ( *, 1070) lag, ((nlppc(lag+1,j,k), k=1,m), j=1,m)
  end do

  return

 1000 format (//' ierr = ', i5)
 1010 format (// 6x, '  ccvf')
 1020 format (// 6x, '   ccf')
 1030 format (// 6x, ' nlppc')
 1040 format (1x, 'lag', 16(5x, i1, ',', i1))
 1060 format (1x, i3, 16f8.4)
 1070 format (1x, i3, 16i8)
end
subroutine ccvf ( y1, y2, n, lagmax, y1mean, y2mean, ccov12, ccov21, iccov )

!*****************************************************************************80
!
!! CCVF computes the cross covariance function between two series.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov12(iccov), ccov21(iccov)
!        the arrays in which the ccvf for series 1 lagged
!        behind series 2 and visa versa, respectively, are
!        stored.
!     real dotxy
!        various cross pruducts between series y1 and y2.
!     integer iccov
!        the row dimension of the arrays ccov12 and ccov21.
!     integer lag
!        the indexing variable indicating the lag value of the
!        autocorrelation being computed.
!     integer lagmax
!        the maximum number of lags to be used.
!     integer n
!        the integer number of observations in the series
!     integer ndotxy
!        the number of observations used to compute dotxy.
!     real y1(n), y1mean
!        the first series, and its mean.
!     real y2(n), y2mean
!        the second series, and its mean.
!
  implicit none

  real &
     y1mean,y2mean
  integer &
     iccov,lagmax,n
!
!  array arguments
  real &
     ccov12(iccov),ccov21(iccov),y1(n),y2(n)
!
!
  real &
     dotxy
  integer &
     lag,ndotxy
!
!  external subroutines
  external dotc
!
!  Compute the cross covariances
!
  call dotc ( y1, y1mean, n, y2, y2mean, n, dotxy, ndotxy)
  ccov12(1) = dotxy / real ( n )
  ccov21(1) = ccov12(1)

  do lag = 1, lagmax

     call dotc (y1, y1mean, n, y2(lag + 1), y2mean, n - lag, dotxy, ndotxy)

     ccov12(lag+1) = dotxy / real ( n )

     call dotc (y2, y2mean, n, y1(lag + 1), y1mean, n - lag, dotxy, ndotxy)

     ccov21(lag+1) = dotxy / real ( n )

  end do

  return
end
subroutine ccvff ( yfft1, yfft2, n, nfft, lagmax, ccov12, ccov21, &
  iccov, lyfft, work, lwork )

!*****************************************************************************80
!
!! CCVFF computes the cross covariance function between two series.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov12(iccov), ccov21(iccov)
!        the arrays in which the ccvf for series 1 lagged
!        behind series 2 and visa versa, respectively, are stored.
!     real fac
!        the appropriate factor used to scale the ccvf.
!     integer i
!        an index variable.
!     integer iccov
!        the dimension of the arrays ccov12 and ccov21.
!     integer lag, lagmax
!        the indexing variable indicating the lag value of the
!        cross correlation being computed, and the maximum lag
!        value to be used.
!     integer lwork
!        the dimension of the vector work.
!     integer lyfft
!        the actual length of the arrays yfft1 and yfft2.
!     integer n
!        the integer number of observations in the series
!     integer nf
!        the number of Fourier frequencies.
!     integer nfft
!        the number of observations in the extended series.
!     integer nfft2
!        the effective number of observations for the fft transform.
!     integer nf2
!        twice the number of Fourier frequencies.
!     real work(lwork)
!        the work array needed for the computations.
!     real yfft1(lyfft), yfft2(lyfft)
!        the vectors containing the observed series already processed
!        by one pass of a fft
!
  implicit none

  integer &
     iccov,lagmax,lwork,lyfft,n,nfft
!
!  array arguments
  real &
     ccov12(iccov),ccov21(iccov),work(lwork),yfft1(lyfft), &
     yfft2(lyfft)

  real &
     fac
  integer &
     i,isn,j,lag,nf,nf2,nfft2
!
!  external subroutines
  external fft,realtr
!
  nfft2 = (nfft-2) / 2
  nf = nfft2 + 1
  nf2 = nf * 2
!
!  Compute the cross covariances
!
  do 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)
  end do

  fac = 1.0e0 / real ( 4 * ( nfft - 2 ) * n )

  isn = -2

  call realtr (work, work(2), nfft2, isn)

  call fft (work, work(2), nfft2, nfft2, nfft2, isn)

  ccov12(1) = work(1) * fac
  ccov21(1) = ccov12(1)

  do lag = 1, lagmax
     ccov21(lag+1) = work(lag+1) * fac
     j = nfft - 1 - lag
     ccov12(lag+1) = work(j) * fac
  end do

  return
end
subroutine ccvfm ( y1, y1miss, y2, y2miss, n, nc, y1mean, y2mean, &
  ccov12, ccov21, iccov, nlpp12, nlpp21 )

!*****************************************************************************80
!
!! CCVFM computes the cross covariance function of two series with missing data.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ccov12(iccov), ccov21(iccov)
!        the arrays in which the ccvf for series 1 lagged
!        behind series 2 and visa versa, respectively, are
!        stored.
!     real dotxy
!        various cross pruducts between series y1 and y2.
!     real fplm
!        the floating point largest magnitude.
!     integer iccov
!        the row dimension of the arrays ccov12 and ccov21.
!     integer lag
!        the indexing variable indicating the lag value of the
!        autocorrelation being computed.
!     integer n
!        the integer number of observations in the series
!     integer nc
!        the number of cross correlations desired.
!     integer nlpp12(iccov), nlpp21(iccov)
!        the number of lagged product pairs used to compute the ccvf
!        for each pair of series at each lag.
!     integer ndotxy
!        the number of observations used to compute dotxy.
!     real y1(n), y1mean, y1miss
!        the first series, and its mean, and missing value code.
!     real y2(n), y2mean, y2miss
!        the second series, and its mean, and missing value code.
!
  implicit none

  real &
     y1mean,y1miss,y2mean,y2miss
  integer &
     iccov,n,nc
!
!  array arguments
  real &
     ccov12(iccov),ccov21(iccov),y1(n),y2(n)
  integer &
     nlpp12(iccov),nlpp21(iccov)

  real &
     dotxy,fplm
  integer &
     lag,ndotxy
!
!  external subroutines
  external dotcm
!
  fplm = huge ( fplm )
!
!  Compute the cross covariances
!
  call dotcm (y1, y1mean, y1miss, n, y2, y2mean, y2miss, n, dotxy, &
     ndotxy)

  nlpp12(1) = ndotxy
  ccov12(1) = fplm
  if (ndotxy  >=  1) ccov12(1) = dotxy / real ( ndotxy )

  ccov21(1) = ccov12(1)
  nlpp21(1) = ndotxy

  do lag = 1, nc

     call dotcm (y1, y1mean, y1miss, n, y2(lag+1), y2mean, y2miss, &
         n-lag, dotxy, ndotxy)

     nlpp12(lag+1) = ndotxy
     ccov12(lag+1) = fplm
     if (ndotxy  >=  1) &
        ccov12(lag+1) = dotxy * real (n-lag) / real (n*ndotxy)

     call dotcm (y2, y2mean, y2miss, n, y1(lag+1), y1mean, y1miss, &
        n-lag, dotxy, ndotxy)

     nlpp21(lag+1) = ndotxy
     ccov21(lag+1) = fplm
     if (ndotxy  >=  1) &
        ccov21(lag+1) = dotxy * real (n-lag) / real ( n * ndotxy )

  end do

  return
end
function cdfchi ( chisqr, df )

!*****************************************************************************80
!
!! CDFCHI computes the CDF for the Chi Square distribution.
!
!  Discussion:
!
!    This routine computes the chi square cumulative distribution
!    function from the incomplete gamma function ratio as discussed in
!    chapter 17 of distributions in statistics - continuous univariate
!    distributions - 1, by Johnson and Kotz.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real chisqr
!        the percent point from the chi squared distribution.
!     real df
!        the degrees of freedom.
!     real fplpm
!        the real floating point largest positive magnitude.
!
  implicit none

  real cdfchi
  real chisqr
  real df
  real fplpm
  real gami
  real gamma
  logical mvchk

  fplpm = huge ( fplpm )

  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<0.0e0) cdfchi = 0.0e0
     if (cdfchi > 1.0e0) cdfchi = 1.0e0
  end if

  return
end
function cdff ( f, df1, df2 )

!*****************************************************************************80
!
!! CDFF computes the CDF for the F distribution.
!
!  Discussion:
!
!    This routine computes the cumulative distribution function for
!    the F distribution.  The approximation used depends on the
!    degrees of freedom in the numerator and denominator.
!
!    1.  If both degrees of freedom are small (less than 4000),
!        the CDF is computed from the incomplete Beta function
!        using equation 5.45 of Statistical Computing, by Kennedy and
!        Gentle.
!
!    2.  if one of the degrees of freedom is large (greater than or
!        equal to 4000) and the other is moderately large (greater than
!        or equal to 100), the cdf is approximated by a normal distrib-
!        bution as shown in equation 20 on page 83 of distributions in
!        statistics - continuous univariate distributions - 2, by
!        johnson and kotz.
!
!    3.  if one of the degrees of freedom is small (less than 100) and
!        the other is large (exceeding 4000), the cdf is approximated
!        by a chi squared distribution as shown in the third equation
!        on page 84 of distributions in statistics - continuous
!        univariate distributions - 2, by johnson and kotz.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real df1
!        the degrees of freedom in the numerator.
!     real df2
!        the degrees of freedom in the denominator.
!     real f
!        the percentage point from the f distribution.
!     real ftrans
!        transforms of the f percentage point, used for the various
!        approximating distributions.
!
  implicit none

  real cdff
  real &
     df1,df2,f
!
!
  real &
     ftrans
!
!  external functions
  real &
      betai,cdfchi,cdfnml
  external  betai,cdfchi,cdfnml

  if ( f <= 0.0e0 ) then
    cdff = 0.0e0
    return
  end if
!
!  both degrees of freedom are less than or equal to 4000.  use
!  the incomplete beta function to compute the f cdf.
!
  if ( df1 <= 4000.0e0 .and. df2 <= 4000.0e0 ) then
    ftrans = df2 / (df2 + df1 * f)
    cdff = 1.0e0 -  betai(ftrans, 0.5e0*df2, 0.5e0*df1)
    return
  end if
!
!  both degrees of freedom exceed 4000.  use the normal approximation
!  to compute the f cdf.
!
  if ( 100.0e0 < df1 .and. 100.0e0 < df2 ) then

    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)))

    cdff = cdfnml(ftrans)

    return
  end if
!
!  the degrees of freedom in the denominator exceeds 4000 and the
!  degrees of freedom in numerator is less than or equal to 100.
!  use the chi square approximation to compute the f cdf.
!
  if ( df1 <= 100.0e0 ) then

    ftrans = &
      (df1 + (df1/df2)*(0.5e0*df1-1.0e0))/ &
      ((1.0e0/f)+(df1/df2)*0.5e0)

    cdff = cdfchi(ftrans, df1)

    return
  end if
!
!  the degrees of freedom in the numerator exceeds 4000 and the
!  degrees of freedom in denominator is less than or equal to 100.
!  use the chi square approximation to compute the f cdf.
!
  ftrans = &
     (df2+(df2/df1)*(0.5e0*df2-1.0e0))/(f+(df2/df1)*0.5e0)

  cdff = 1.0e0 - cdfchi(ftrans, df2)

  return
end
function cdfnml ( x )

!*****************************************************************************80
!
!! CDFNML computes the CDF for the standard normal distribution.
!
!  Discussion:
!
!    This routine computes the normal cumulative distribution
!    function from the error function as described in chapter 13
!    of distributions in statistics - continuous univariate
!    distributions - 1, by Johnson and Kotz.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real x
!        the percent point from the chi squared distribution.
!
  implicit none

  real cdfnml
  real erf
  real x

  cdfnml = 0.5e0 * (1.0e0 +  erf(x/sqrt(2.0e0)))

  return
end
function cdft ( x, idf )

!*****************************************************************************80
!
!! CDFT computes the CDF for Student's T distribution.
!
!  Discussion:
!
!    This routine computes the cumulative distribution function value 
!    for Student's T distribution with integer degrees of freedom 
!    parameter = idf.
!
!    This distribution is defined for all X.
!    The probability density function is given
!    in the references below.
!
!  Author:
!
!    James Filliben,
!    Statistical Engineering Laboratory,
!    National Bureau of Standards,
!    Washington, DC 20234.
!
!  Reference:
!
!    Formulas 26.7.3 and 26.7.4,
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    National Bureau of Standards, 1964,
!    LC: QA47.A34,<br>
!    ISBN: 0-486-61272-4.
!
!    Enrico Federghi,
!    Extended Tables of the Percentage Points of Student's T-Distribution,
!    Journal of the American Statistical Association,
!    Volume 54, Number 287, 1959, pages 683-688.
!
!    Johnson, Kotz, 
!    Continuous Univariate Distributions, 
!    1970, pages 94-129.
!
!    Owen, 
!    Handbook of Statistical Tables,
!    1962, pages 27-30.
!
!    Pearson, Hartley, 
!    Biometrika Tables for Statisticians, 
!    volume 1, 1954, pages 132-134.
!
!  Parameters:
!
!     input  arguments--x      = the value at
!                                which the cumulative distribution
!                                function is to be evaluated.
!                                x should be non-negative.
!
!                     --idf     = the integer number of degrees
!                                of freedom.
!                                idf should be positive.
!
!     output arguments--cdf    = the single precision cumulative
!                                distribution function value.
!
!     output--the single precision cumulative distribution
!             function value cdf for the student"s t distribution
!             with degrees of freedom parameter = idf.
!
!  Local Parameters:
!
!     real b11, b21, b22, b23, b24, b25
!        constants used in the computations.
!     real b31, b32, b33, b34, b35, b36, b37
!        constants used in the computations.
!     real df
!        the degrees of freedom.
!     real d1, d11, d3, d5, d7, d9
!        constants used in the computations.
!     real fpspm
!        the floating point smallest positive magnitude.
!     integer i
!        an index.
!     integer idf
!        the degrees of freedom.
!     real x
!        the t statistic.
!
  implicit none

  real cdft
  integer idf
  real x

  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
!
!  external functions
  real &
     cdfnml
  external cdfnml

  data idfcut /1000/
  data dconst /0.3989422804e0/
  data b11 /0.25e0/
  data b21 /96.0e0/
!     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/

  call getpi(pi)
  fpspm = tiny ( fpspm )
!
!  check the input arguments for errors
!
  if (idf <= 0) then
    write ( *, 1000)
    write ( *, 1010) idf
    cdft = 0.0e0
    return
  end if

  df = real ( idf )
!
!  if idf is 3 through 9 and x is more than 3000
!  standard deviations below the mean,
!  set cdft = 0.0e0 and return.
!  if idf is 10 or larger and x is more than 150
!  standard deviations below the mean,
!  set cdft = 0.0e0 and return.
!  if idf is 3 through 9 and x is more than 3000
!  standard deviations above the mean,
!  set cdft = 1.0e0 and return.
!  if idf is 10 or larger and x is more than 150
!  standard deviations above the mean,
!  set cdft = 1.0e0 and return.
!
  if (idf <= 2) go to 50
  sd = sqrt(df/(df-2.0e0))
  z = x/sd
  if (idf<10 .and. z<(-3000.0e0)) go to 30
  if (idf >= 10 .and. z<(-150.0e0)) go to 30
  if (idf<10 .and. z > 3000.0e0) go to 40
  if (idf >= 10 .and. z > 150.0e0) go to 40
  go to 50
   30 cdft = 0.0e0
  return
   40 cdft = 1.0e0
  return
   50 continue
!
!  distinguish between the small and moderate
!  degrees of freedom case versus the
!  large degrees of freedom case
!
  if (idf<idfcut) go to 60
  go to 120
!
!  treat the small and moderate degrees of freedom case
!  method utilized--exact finite sum
!  (see ams 55, page 948, formulae 26.7.3 and 26.7.4).
!
   60 continue
  csq = df/(x*x+df)
  c = sqrt(csq)
  imax = idf - 2
  ievodd = idf - 2*(idf/2)

  if (ievodd /= 0) then
     if (idf == 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

  do i=imin,imax,2
     if (term /= 0.0e0) then
        if (log(term)+log(real (i-1)/real ( i ) )+log(csq) >= log(fpspm)) then
           term = term*( real ( i - 1 ) / real ( i ) ) * csq
           sum = sum + term
        else
           term = 0.0e0
        end if
     end if
  end do

  if (sum == 0.0e0 .or. x == 0.0e0) then
     sum = 0.0e0
  else
     if (log(sum)+log(abs(x))-0.5*log(x*x+df) < log(fpspm)) then
        sum = 0.0e0
     else
        sum = sum*x/sqrt(x*x+df)
     end if
  end if

  if ( ievodd /= 0 ) then
    sum = (2.0e0/pi)*(atan(x/sqrt(df))+sum)
  end if

  cdft = 0.5e0 + sum/2.0e0

  return
!
!  treat the large degrees of freedom case.
!  method utilized--truncated asymptotic expansion
!  (see johnson and kotz, volume 2, page 102, formula 10?
!  see federighi, page 687).
!
  120 continue
  d1 = x
  d3 = x**3
  d5 = x**5
  d7 = x**7
  d9 = x**9
  d11 = x**11
  term1 = b11*(d3+d1)/df
!     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

 1000 format ('***** fatal error--the second input argument to t', &
     'he cdft   subroutine is non-positive *****')
 1010 format ('***** the value of the argument is ', i8, ' *****')
end
subroutine center ( y, n, yc )

!*****************************************************************************80
!
!! CENTER centers an observed series.
!
!  Discussion:
!
!    This is the user routine for centering the observed series Y,
!    returning the centered series in YC.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical err01
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     character*1 ln(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     real y(n)
!        the vector containing the observed time series.
!     real yc(n)
!        the vector in which the centered series is returned.
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     y(*),yc(*)
!
!  scalars in common
  integer &
     ierr

  logical &
     err01,head
!
!  local arrays
  character &
     ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external cntr,eisge
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 2, 1, head, err01, ln)

  if ( err01 ) then
    ierr = 1
    return
  end if

  call cntr (y, n, yc)

  return
end
subroutine chirho ( rho, n, nc, chi, chip )

!*****************************************************************************80
!
!! CHIRHO computes the Chi Square statistic and its probability.
!
!  Discussion:
!
!    This routine computes the chi squared statistic and its
!    probability based in a vector of autocorrelations.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real chi, chip
!        the variables in which the chi square statistic and
!        chi square statistic probability are stored.
!     integer lag
!        the indexing variable indicating the lag value of the
!        autocorrelation being examined.
!     integer n
!        the number of observations in the series.
!     integer nc
!        the number of autocorrelations computed.
!     real rho(nc)
!        the array in which the autocorrelations are stored
!
  implicit none

  real cdfchi
  real chi
  real chip
  integer n
  integer nc
  real rho(*)

  chi = dot_product ( rho(1:nc), rho(1:nc) )
  chi = chi * real ( n )
  chip = 1.0e0 - cdfchi ( chi, real(nc) )

  return
end
subroutine cmpfd ( n, stp, pvstp, pv, fd )

!*****************************************************************************80
!
!! CMPFD computes a finite difference derivative.
!
!  Discussion:
!
!    This routine computes a finite difference derivative,
!    assuming that if the difference between pvstp(i) and pv(i) is
!    small enough the derivative is zero.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index variable.
!     real fd(n)
!        the finite-difference derivative.
!     real fplrs
!        the floating point largest relative spacing.
!     real pv(n)
!        the predicted values at the current parameter value.
!     real pvstp(n)
!        the predicted values at the current parameter value plus stp.
!     real stp
!        the step.
!
  implicit none

  real &
     stp
  integer &
     n
!
!  array arguments
  real &
     fd(*),pv(*),pvstp(*)

  real &
     fplrs
  integer &
     i

  fplrs = epsilon ( fplrs )

  do i=1,n
     fd(i) = pvstp(i) - pv(i)
     if (abs(fd(i)) >= 5*fplrs*min(abs(pvstp(i)),abs(pv(i)))) then
        fd(i) = fd(i) / stp
     else
        fd(i) = 0.0e0
     end if
  end do

  return
end
subroutine cntr ( y, n, yc )

!*****************************************************************************80
!
!! CNTR centers the input seriers about its mean.
!
!  Discussion:
!
!    This routine centers the input series Y about its mean,
!    returning the centered series in YC.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index variable.
!     integer n
!        the number of observations in the input series.
!     real y(n)
!        the input array of observations to be centered.
!     real yc(n)
!        the output array of centered observations.
!     real ymean
!        the mean of the input series.
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     y(*),yc(*)

  real &
     ymean

  call amean ( y, n, ymean )

  yc(1:n) = y(1:n) - ymean

  return
end
subroutine correr ( nmsub, m, n, iym, ivcv, ldstak, icor, nprt )

!*****************************************************************************80
!
!! CORRER checks for errors in the input parameters.
!
!  Discussion:
!
!    This routine checks for errors in the input parameters.
!    If any are found a flag is set and computation stops.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical err01, err02, err03, err04, err05
!                  value(s) indicating whether or error was detected
!                  (true) or not (false).
!     logical head
!                  a flag indicating whether the heading should be
!                  printed (true) or not (false).  if a heading is
!                  printed, the value of head will be changed to false.
!     integer icor
!                  determines which subroutine called correr
!                  if =1, then called by corr
!                     =2, then called by corrs
!     integer ierr
!                  a flag, that when returned by this routine designates
!                  whether  errors were detected in the parameter list
!                  if ierr == 0, no errors were detected
!                  if ierr == 1, errors have been detected
!     integer ip
!                  a temporary variable used for computing ldsmin.
!     integer is
!                  a temporary variable used for computing ldsmin.
!     integer ivcv
!                  the dimension of sc
!     integer iym
!                  actual row dimension of ym
!     integer ldsmin
!                  the minimum length allowed for dstak
!     integer ldstak
!                  the length of the vector dstak in common cstak
!     character*1 livcv(8), liym(8), llds(8), lm(8), ln(8), lthree(8),
!    *  ltwo(8)
!                  the array(s) containing the name(s) of the
!                  variable(s) checked for errors.
!     integer m
!                  number of variables
!     integer n
!                  the number ofobservations
!     character*1 nmsub(6)
!                  the name of the calling subroutine.
!     integer nprt
!                  the variable controlling the printed output.
!                  if nprt=0, output is suppressed, otherwise it is not
!
  implicit none

  integer &
     icor,ivcv,iym,ldstak,m,n,nprt
!
!  array arguments
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr

  integer &
     ip,is,ldsmin
  logical &
     err01,err02,err03,err04,err05,head
!
!  local arrays
  character &
     livcv(8)*1,liym(8)*1,llds(8)*1,lm(8)*1,ln(8)*1, &
     lthree(8)*1,ltwo(8)*1
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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', ' ', ' ', ' ', ' ', ' '/

  head = .true.

  ierr = 0
!
!  number of variables less than 2.
!
  call eisge(nmsub, lm, m, 2, 2, head, err01, ltwo)
!
!  number of observations less than 3.
!
  call eisge(nmsub, ln, n, 3, 2, head, err02, lthree)
!
!  observation matrix dimensioned less than n.
!
  err03 = .false.
  if (.not.err02) call eisge(nmsub, liym, iym, n, 3, head, err03, &
     ln)
!
!  sc matrix dimensioned less than m.
!
  err04 = .false.
  if ((icor == 2) .and. (.not.err01)) call eisge(nmsub, livcv, &
     ivcv, m, 3, head, err04, lm)

  if ( err01 .or. err02 ) then
    ierr = 1
    return
  end if

  is = 0
  if (icor == 1) is = 1

  ip = 1
  if (nprt == 0) ip = 0
!
!  check for enough common for this problem
!
  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)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err05, llds)

  if (err01 .or. err02 .or. err03 .or. err04 .or. err05) then
    ierr = 1
    return
  end if

  return
end
subroutine corr ( ym, n, m, iym, ldstak )

!*****************************************************************************80
!
!! CORR: short call to correlation family of routines.
!
!  Discussion:
!
!    This is the user callable routine for the correlation family.
!    it is the short call form.
!    This procedure calls corer to check for errors in the parameter
!    list.  If no problems it then allocates space in cstak for the
!    vectors needed and calls the main routine CORRMN to
!    do the correlation analysis.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer avg
!                  the starting location in the work area for the
!                  averages of ym
!     integer cilo
!                  occupies the same space as slpc and is the lower
!                  confidence interval
!     integer ciup
!                  occupies the same space as slsc and is the upper
!                  confidence interval
!     double precision dstak(12)
!                  the double precision version of
!                  the /cstak/ work area.
!     integer icor
!                  determines which subroutine called CORRMN
!                  if =1, then called by corr
!                     =2, then called by corrs
!     integer ierr
!                  a flag returned to the user indicating
!                  whether  errors were detected in the parameter list
!                  if ierr == 0, no errors were detected
!                  if ierr == 1, errors have been detected
!     integer ifp
!                  an indicator for stack allocation type, where ifp=3
!                  indicates single precision and ifp=4 indicates
!                  double precision.
!     integer istak(12)
!                  the integer version of the /cstak/ work area.
!     integer iwrk
!                  the starting location in the work area for the
!                  integer work vector.
!     integer iym
!                  the row dimension of ym specified in the users progra
!     integer ldstak
!                  size of work area allocated in the users program
!     integer liwrk
!                  the length of the integer work vector.
!     integer lwrk
!                  the length of the real work vector.
!     integer m
!                  the number of variables
!     integer n
!                  the number of observations
!     integer nall0
!                  the number of allocations outstanding at the
!                  time that this routine was called.
!     character*1 nmsub(6)
!                  the subroutine name
!     integer nprt
!                  the variable controlling the automatic printout
!                       nprt = 0, printout is suppressed
!                       otherwise the printout is provided.
!     integer pc
!                  the starting location in the work area
!                  of the partial correlation coefficients matrix
!     integer qf
!                  the starting location in the work area for the
!                  quadratic fit
!     integer quad
!                  the starting location in the work area for the
!                  real version of the quadratic fit
!     integer rank
!                  the starting location in the work area for the
!                  matrix containing the ranks of ym
!     real rstak(12)
!                  the real version of the
!                  /cstak/ work area.
!     integer sc
!                  the starting location in the work area
!                  of the simple correlation coefficients matrix
!     integer scinv
!                  the starting location in the work area for the
!                  inverse matrix of sc
!     integer sd
!                  the starting location in the work area of the
!                  standard deviations of ym
!     integer slpc
!                  the starting location in the work area of the
!                  significance levels of pc
!     integer slsc
!                  the starting location in the work area of the
!                  significance levels of sc
!     integer srcc
!                  the starting location in the work area of the
!                  spearman rank coefficients
!     integer t
!                  starting location in the work area
!                  for the array t.
!     integer vcv
!                  the starting location in the work area of the
!                  variance covariance matrix.
!     integer wrk
!                  the starting location in the work area for
!                  work space
!     real ym(iym,m)
!                  the matrix in which the observations are passed
!
  implicit none

  integer &
     iym,ldstak,m,n
!
!  array arguments
  real &
     ym(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     avg,cilo,ciup,icor,ifp,iwrk,liwrk,lwrk,nall0,nprt,pc, &
     qf,quad,rank,sc,scinv,sd,slpc,slsc,srcc,t,vcv,wrk
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name array
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       'c',      'o',      'r',      'r',      ' ',      ' '/
!
!  set up framework variables for number type
!
  ifp = 3
!
!  set caller flag, this is corr
!
  icor = 1
!
!  printout is automaticaly provided
!
  nprt = 1
!
!  check for errors in parameters
!
  call correr(nmsub, m, n, iym, m, ldstak, icor, nprt)
!
!  if there is an error return to the callers routine
!
  if ( ierr /= 0 ) then
    return
  end if
!
!  initialize the stack
!
  call stkset (ldstak, 4)
  nall0 = stkst(1)
!
!  allocate space in cstak for matrices.
!
  liwrk = max(n,m)
  lwrk = liwrk

  vcv = stkget(m*m,ifp)
  iwrk = stkget(liwrk,2)
  wrk = stkget(lwrk,ifp)

  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)
!
!  the following variables have been indirectly equivalenced-
!
  ciup = slsc
  cilo = slpc
  avg = wrk
  sd = wrk
  srcc = scinv
!
!  call the routine to do the computations
!
  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 )
!
!  return area to the work array
!
  call stkclr(nall0)

  return
end
subroutine corrhd ( m, n )

!*****************************************************************************80
!
!! CORRHD prints headers for the correlation family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer m
!        the number of variables
!     integer n
!        the number of observations for each variable
!
  implicit none

  integer m,n
!
!  external subroutines
  external versp

  call versp(.true.)
  write ( *,1000) m, n
  return

 1000 format (/' correlation analysis for', i3, ' variables with', &
     i5, ' observations'/)
end
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 )

!*****************************************************************************80
!
!! CORRMN is the main routine in the correlation family.
!
!  Discussion:
!
!    This is the main routine for the correlation family.
!
!    It was adapted from the omnitab routine correl. it does a  correlation
!    analysis of a multivariate random sample.
!    the following tables are produced
!      simple correlation coefficients,
!      partial correlation coefficients,
!      and their siginificance levels,
!      spearman rank coefficients,
!      quadratic relationship,
!      95 and 99 percent confidence intervals.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real avg(m)
!                  contains the column averages of ym
!     real b
!                  = (n-1) * n * (n+1) / 6
!     real cilo(m,m)
!                  lower confidence interval for sc
!     real ciup(m,m)
!                  upper confidence interval for sc
!     real d(3)
!                  a dummy array.
!     real f
!                  square root of fn3
!     real fn3
!                  real representation of (n-3).
!     real fplm
!                  the floating point largest magnitude
!     integer ier
!                  error flag for subroutines called from this routine
!     integer ierr
!                  when returned by this routine, desginates whether any
!                  errors were detected during computations
!                     if ierr == 0, no errors
!                             == 1, errors were detected
!     integer inert(3)
!                  the inertia of the simple correlation matrix.
!     integer ivcv
!                  the row dimension of vcv specified in the users progr
!     integer iwrk(liwrk)
!                  a work vector for the inversion routine
!     integer iym
!                  the row dimension of ym specified in the users progra
!     integer liwrk
!                  the length of the integer work vector.
!     integer lwrk
!                  the length of the real work vector.
!     integer m
!                  the number of variables (the column dimension of ym)
!     integer n
!                  the number of observations
!     integer nprt
!                  the variable controlling the automatic printout
!                  nprt =0, printout is suppressed
!                  otherwise printout is provided
!     integer nsum
!                  the number of observations in the dot product
!     real pc(m,m)
!                  partial correlation coefficients matrix
!     real qf(m,m)
!                  quadratic fix matrix
!     real quad(n,3)
!                  double version of qf matrix
!     real rank(n,m)
!                  the matrix containg the ranks of ym
!     real sc(m,m)
!                  simple correlation coefficients matrix
!     real scinv(m,m)
!                  the inverse matrix of sc
!     real sd(m)
!                  standard deviation of the comlumns of ym
!     real slpc(m,m)
!                  significance levels of pc
!     real slsc(m,m)
!                  significance levels of sc
!     real sqsum
!                  the sum of squares of the ith column of ym
!     real srcc(m,m)
!                  spearman rank correlation coefficients
!     real sum
!                  used in calculating the statistics of ym
!     real t(m)
!                  used in determining srcc
!     real vcv(ivcv,m)
!                  the variance covariance matrix.
!     real wrk(lwrk)
!                  work storage
!     real ym(iym,m)
!                  the matrix whose columns each contain one of m sets
!                  of n observations. each column represents a different
!                  variable
!     real z
!                  used in computing confidence intervals
!     real zz
!                  used in determining correlation coefficients
!
  implicit none

  integer &
     ivcv,iym,liwrk,lwrk,m,n,nprt
!
!  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)
!
!  scalars in common
  integer &
     ierr

  real &
     b,f,fn3,fplm,hl1,hl2,sqsum,sum,z,zz
  integer &
     i,ier,j,k,k1,k2,nsum
!
!  local arrays
  real &
     c(3),d(3),rr(3,3),xx(3)
  integer &
     inert(3)
!
!  external functions
  real &
     cdff
  external cdff
!
!  common blocks
  common /errchk/ierr

  ierr = 0

  fplm = huge ( fplm )

  do j=1,m
    call amean(ym(1,j), n, avg(j))
  end do
!
!  compute variance-covariance matrix
!
  do j=1,m
    do i=j,m
      call dotc(ym(1,j), avg(j), n, ym(1,i), avg(i), n, sum, nsum)
      vcv(j,i) = sum / real ( nsum - 1 )
      vcv(i,j) = vcv(j,i)
    end do
  end do

  if (nprt == 0) then
    return
  end if
!
!  print variance-covariance matrix and simple correlation
!  coefficients
!
  call corrhd ( m, n )
  call vcvout ( m, vcv, ivcv, .false.)
!
!  compute standard deviations
!
  do i=1,m
     if ( vcv(i,i) <= 0.0e0 ) then
       ierr = 1
       return
     end if
     sd(i) = sqrt(vcv(i,i))
  end do
!
!  Compute simple correlation coefficients
!
  do j=1,m
     do i=j,m
        sc(i,j) = 1.0e0
        scinv(j,i) = 1.0e0
        if (i /= j) then
          sc(i,j) = vcv(i,j)/sd(i)/sd(j)
          sc(j,i) = sc(i,j)
          scinv(j,i) = sc(i,j)
        end if
      end do
  end do

  if ((m <= 2) .or. (n <= m)) go to 190
!
!  Calculate partial correlation coefficients.
!
  call ssifa(scinv, m, m, iwrk, ier)

  if ( ier /= 0 ) then
    write ( *,1000)
    ierr = 1
    return
  end if

  call ssidi(scinv, m, m, iwrk, d, inert, wrk, 1)

  do j=1,m
     do i=j,m
        pc(i,j) = 1.0e0
        if (i  /=  j) then
          zz = scinv(i,i)*scinv(j,j)
          pc(i,j) = fplm

          if ( 0.0 < zz ) then
            pc(i,j) = -scinv(j,i)/sqrt(zz)
            if (abs(pc(i,j)) > 1.0e0) pc(i,j) = sign(1.0e0,pc(i,j))
          end if

          pc(j,i) = pc(i,j)
        end if

    end do

  end do
!
!  compute significance levels of partial correlation coefficients.
!  note, lower triangular matrix stored in square matrix.
!
  do i=1,m

     do j=1,i

        if ( pc(i,j) == 0.0e0) then
          slpc(i,j) = 1.0e0
        else if ( 1.0 <= abs(pc(i,j)) ) then
          slpc(i,j) = 0.0e0
        else
          f = pc(i,j)*pc(i,j)
          if ( 1.0e0-f == 0.0e0) then
            slpc(i,j) = fplm
          else
            f = real ( n - m ) * f/(1.0e0-f)
            slpc(i,j) = 1.0e0 - cdff(f,1.0e0,real(n-m))
          end if
        end if

    end do

  end do
!
!  Compute significance levels of simple correlation coefficients
!  note, only lower triangular stored in square matrix.
!
  190 continue

  do i=1,m
    do j=1,i

      if (i == j) then
        slsc(i,j) = 0.0e0
      else if (sc(i,j) == 0.0e0) then
        slsc(i,j) = 1.0e0
      else if ( 1.0 <= abs(sc(i,j)) ) then
        slsc(i,j) = 0.0e0
      else
        f = sc(i,j)*sc(i,j)
        if (f == 1.0e0) then
          slsc(i,j) = fplm
        else
          f = real(n-2)*f / (1.0e0-f)
         slsc(i,j) = 1.0e0 - cdff(f,1.0e0,real(n-2))
        end if
      end if

    end do
  end do
!
!  print significance levels of simple correlation coefficients,
!  partial correlation coefficients and significance levels
!
  write ( *,1020)
  call matprt(slsc, slsc, m, 0, 1, m)

  if ((m > 2) .and. (n > m)) then
    i = m - 2
    write ( *,1030) i
    call matprt(pc, pc, m, 0, 1, m)
    write ( *,1040)
    call matprt(slpc, slpc, m, 0, 1, m)
  else
    write ( *,1010)
  end if
!
!  Determine the ranks of the observations.
!
  do i=1,m
    call ranko(n, ym(1,i), iwrk, rank(1,i), t(i))
    t(i) = t(i) / 12.0e0
  end do
!
!  compute spearman rank correlation coefficients.
!  note, lower triangular matrix, stored in square matrix.
!
  b = real ( (n-1)*n*(n+1)/6 )
  do i=1,m
    do j=1,i
      srcc(i,j) = 1.0e0
      if ( i /= j ) then
        k1 = int ( 2.0e0*t(i) + 0.4e0 )
        k2 = int ( 2.0e0*t(j) + 0.4e0 )
        srcc(i,j) = fplm
        if ((int(b)-k1 <= 0) .or. (int(b)-k2 <= 0)) then
          cycle
        end if
        sum = 0.0e0
        do k=1,n
           zz = rank(k,i) - rank(k,j)
           sum = sum + zz*zz
        end do
        zz = (b - 2.0e0*t(i))*(b - 2.0e0*t(j))
        if (zz > 0.0e0) srcc(i,j) = (b-sum-t(i)-t(j))/sqrt(zz)
      end if
    end do
  end do
!
!  print spearman rank correlations coefficients
!
  write ( *,1050)
  call matprt(srcc, srcc, m, 0, 1, m)

  if ( n <= 3 ) then
    write ( *,1060)
    return
  end if
!
!  compute the significance levels of the quadratic fit over the
!  linear fit.
!
!  these calculations may produce variable results in varying
!  machine/compilation environments, in cases in which the
!  ym matrix is near singular (essentially singular but the
!  singularity is undetected by the code).  the observed symptoms
!  are alternation between qf values of 0.0e0 (first f = line
!  produces zero) and 1.0e0 (first f = line produces approx.
!  zero, and numerator in second f = line is nonzero).
!
  fn3 = real ( n - 3 )

  do j=1,m
     do i=1,m

        if ( i == j) then
          qf(i,j) = 1.0e0
          cycle
        end if

        sqsum = 0.0e0

        do 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)
        end do
        call mgs(quad, wrk, n, 3, xx, c, d, rr, 3, n, ier)

        if ( ier /= 0) then
          write ( *,1090)
          go to 420
        end if

        do k=1,3
           c(k) = c(k)*sqrt(d(k))
        end do

        f = (sqsum-c(1)*c(1)-c(2)*c(2)-c(3)*c(3))
        qf(i,j) = 0.0e0

        if ( f /= 0.0e0 ) then
          f = (c(3)*c(3)*fn3)/f
          qf(i,j) = 1.0e0
          if (f > 0.0e0) qf(i,j) = 1.0e0 - cdff(f,1.0e0,fn3)
        end if

    end do
  end do
!
!  print the quadratic fit matrix
!
  j = 2
  k = 1
  i = n - 3
  write ( *,1070) i, qf(j,k), j, k
  call matprt(qf, qf, m, 1, 1, m)
!
!  compute confidence limits for simple correlation coefficients
!
  420 continue

  f = sqrt(fn3)
  hl1 = 2.5758293e0 / f
  hl2 = 1.9599640e0 / f

  do j=1,m

    do i=1,m

      if (i == j) then

        ciup(i,j) = 99.0e0
        cilo(i,j) = 95.0e0
!
!  Compute 99 percent intervals.
!
      else if (i<j) then

        if ( 1.0 <= sc(j,i) ) then
          z = 1.0
        else if ( sc(j,i) <= -1.0 ) then
          z = -1.0
        else
          z = 0.5e0*log((1.0e0+sc(j,i))/(1.0e0-sc(j,i)))
        end if

        ciup(i,j) = min(tanh(z+hl1),1.0e0)
        cilo(i,j) = max(tanh(z-hl1),-1.0e0)
!
!  compute 95 percent intervals.
!
      else

        if ( 1.0 <= sc(i,j) ) then
          z = 1.0
        else if ( sc(i,j) <= -1.0 ) then
          z = -1.0
        else
          z = 0.5e0*log((1.0e0+sc(i,j))/(1.0e0-sc(i,j)))
        end if

        ciup(i,j) = min(tanh(z+hl2),1.0e0)
        cilo(i,j) = max(tanh(z-hl2),-1.0e0)

      end if

    end do

  end do
!
!  Print confidence limits
!
  write ( *,1080)
  call matprt(ciup, cilo, m, 1, 2, m)

  return

 1000 format (/ ' computation stopped due to singular or ill-co', &
     'nditioned covariance matrix.')
 1010 format (//' the partial correlation coefficients (and', ' signi', &
     'ficance levels) are not printed or defined because'/' eithe', &
     'r the number of vectors being compared is two or the', &
     ' number of measurements is less than or equal to the number'/ &
     ' of vectors being compared.')
 1020 format (// ' significance levels of simple correlation c', &
     'oefficients (assuming normality)')
 1030 format (// ' partial correlation coefficients with', i3, &
     ' remaining variables fixed')
 1040 format (// ' significance levels of partial correlation ', &
     'coefficients (assuming normality)')
 1050 format (// ' spearman rank correlation coefficients (adj', &
     'usted for ties)')
 1060 format (// ' nonlinearity test and approximation of conf', &
     'idence intervals not defined for n = 3.')
 1070 format (// ' significance level of quadratic fit over lin', &
     'ear fit based on f ratio with 1 and', i5, ' degrees of fre', &
     'edom'/' (for example,', f7.4, ' is the significanc', &
     'e level of the quadratic term when column', i3, ' is fitte', &
     'd to column', i3, ')')
 1080 format (// ' confidence intervals for simple correlation', &
     ' coefficients (using fisher transformation)'/' 95 per c', &
     'hent limits below diagonal, 99 per cent limits above diagona', &
     'l')
 1090 format (/ ' significance levels of quadratic fit over lin', &
     'ear fit have not been computed'/' due to singularity in', &
     ' design matrix. check your data.')
end
subroutine corrs ( ym, n, m, iym, ldstak, nprt, vcv, ivcv )

!*****************************************************************************80
!
!! CORRS is the user routine for the correlation, with a long call interface.
!
!  Discussion:
!
!    This is the user callable routine for the correlation family.
!    it is the long call form.
!    this routine calls correr to check for errors in the parameters.
!    if there are no problems it then allocates space in cstak
!    for the vectors needed and calls the main routine, corrmn, to do
!    the correlation analysis.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer avg
!                  the starting location in the work area of the
!                  averages of ym
!     integer cilo
!                  occupies the same space as slpc and is the lower
!                  confidence interval
!     integer ciup
!                  occupies the same space as slsc and is the upper
!                  confidence interval
!     double precision dstak(12)
!                  the double precision version of
!                  the /cstak/ work area.
!     integer icor
!                  determines which subroutine called corrmn
!                  if =1, then called by corr
!                     =2, then called by corrs
!     integer ierr
!                  a flag returned to the user indicating
!                  whether  errors were detected in the parameter list
!                  if ierr == 0, no errors were detected
!                  if ierr == 1, errors have been detected
!     integer ifp
!                  an indicator for stack allocation type, where ifp=3
!                  indicates single precision and ifp=4 indicates
!                  double precision.
!     integer istak(12)
!                  the integer version of the /cstak/ work area.
!     integer ivcv
!                  the dimension of vcv assigned in the users program.
!     integer iwrk
!                  the starting location in the work area for the
!                  integer work vector.
!     integer iym
!                  row dimension of ym specified in the users program.
!     integer ldstak
!                  size of work area allocated in the users program
!     integer liwrk
!                  the length of the integer work vector.
!     integer lwrk
!                  the length of the real work vector.
!     integer m
!                  the number of variables
!     integer n
!                  the number of observations
!     integer nall0
!                  the number of allocations outstanding at the
!                  time that this routine was called.
!     character*1 nmsub(6)
!                  the subroutine name
!     integer nprt
!                  the variable controlling the automatic printout
!                  nprt = 0 printout is supressed
!                  otherwise the printout is provided.
!     integer pc
!                  the starting location in the work area for the
!                  the partial correlation coefficients matrix
!     integer qf
!                  the starting location in the work area for the
!                  quadratic fit matrix
!     integer quad
!                  the starting location in the work area for the
!                  real  quad fit
!     integer rank
!                  the starting location in the work area for the
!                  matrix containing the ranks of ym
!     real rstak(12)
!                  the real version of
!                  the /cstak/ work area.
!     integer sc
!                  the starting location in the work area for the
!                  the simple correlation coefficients matrix
!     integer scinv
!                  the starting location in the work area of the
!                  inverse matrix of vcv
!     integer sd
!                  the starting location in the work area of the
!                  standard deviations vector
!     integer slpc
!                  the starting location in the work area of the
!                  significance levels for pc
!     integer slsc
!                  the starting location in the work area of the
!                  significance levels for sc
!     integer srcc
!                  starting location in the work area for the spear-
!                  man rank coefficients
!     integer t
!                  starting location in the work area
!                  for the work vector t
!     real vcv(ivcv,m)
!                  the variance covariance matrix
!     integer wrk
!                  the starting location in the work area for
!                  work space
!     real ym(iym,m)
!                  the observation matrix
!
  implicit none

  integer &
     ivcv,iym,ldstak,m,n,nprt
!
!  array arguments
  real &
     vcv(*),ym(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     avg,cilo,ciup,icor,ifp,iwrk,liwrk,lwrk,nall0,pc,qf, &
     quad,rank,sc,scinv,sd,slpc,slsc,srcc,t,wrk
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name array
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       'c',      'o',      'r',      'r',      's',      ' '/
!
!  set up framework variables for number types
!
  ifp = 3
!
!  set the caller flag, this is corrs
!
  icor = 2
!
!  check for errors in parameters
!
  call correr(nmsub, m, n, iym, ivcv, ldstak, icor, nprt)
!
!  print correct form of call statement and return to caller
!
  if (ierr /= 0) then
    return
  end if
!
!  initialize the stack
!
  call stkset (ldstak, 4)
  nall0 = stkst(1)
!
!  allocate space in dstak for matrices
!
  liwrk = max(n,m)
  lwrk = liwrk

  wrk = stkget(lwrk,ifp)

  if (nprt == 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
!
!  The following variables have been indirectly equivalenced:
!
  ciup = slsc
  cilo = slpc
  avg = wrk
  sd = wrk
  srcc = scinv

  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)
!
!  Return area to work.
!
  call stkclr(nall0)

  return
end
subroutine corrxp ( m, vcv, ivcv )

!*****************************************************************************80
!
!! CORRXP prints stored output returned from CORRS.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ivcv
!        the first dimension of the matrix vcv
!
!     integer m
!        the number of variables in the analysis
!
!     real vcv(ivcv,m)
!        arrays to be printed
!
  implicit none

  integer ivcv,m
!
!  array arguments
  real &
     vcv(*)

  if ( m <= ivcv ) then

     write ( *, '(a)' ) ' '
     write ( *, '(a)' ) 'Storage from CORRS.'
     write ( *, '(a)' ) 'Storage from variance-covariance matrix.'

     call matprt(vcv, vcv, m, 1, 1, ivcv)

  end if

  return
end
subroutine covclc ( covirc, d, iv, j, n, nn, p, r, v, x )

!***********************************************************************
!
!! COVCLC computes the covariance matrix for NL2ITR.
!
!  Discussion:
!
!    Let K = abs ( IV(COVREQ) ).
!
!    For K <= 2, a finite-difference hessian H is computed,
!    * using function and gradient values if IV(COVREQ) is nonnegative,
!    * using only function values if IV(COVREQ) is negative).
!
!    Let
!      SCALE = 2 * F(X) / max ( 1, N - P ),
!    where 2 * F(X) is the residual sum of squares.
!
!    COVCLC computes:
!      K = 0 or 1:  SCALE * inverse ( H ) * ( J' * J ) * inverse ( H ).
!      K = 2:       SCALE * inverse ( H );
!      K >= 3:      SCALE * inverse ( J' * J ).
!
!  Modified:
!
!    13 April 2006
!
!  Parameters:
!
!    Output, integer COVIRC, is set to 1, 2, 3, or 4 depending on
!    the circumstances of the calculation.
!
!    Input, real D(P), the scaling vector.
!
!    Input/output, integer IV(*), the NL2SOL integer parameter vector.
!
!    Input, real J(NN,P), the N by P Jacobian matrix.
!
!    Input, integer N, the number of functions.
!
!    Input, integer NN, the leading dimension of J.
!
!    Input, integer P, the number of variables.
!
!    ?, real R(N), ?
!
!    Input, real V(*), the NL2SOL real parameter array.
!
!    ?, real X(P), ?
!
  implicit none

  integer n
  integer nn
  integer p

  integer cov
  integer covirc
  integer, parameter :: covmat = 26
  integer, parameter :: covreq = 15
  real d(p)
  real del
  integer, parameter :: delta = 50
  integer, parameter :: delta0 = 44
  integer, parameter :: dltfdc = 40
  integer, parameter :: f = 10
  integer, parameter :: fx = 46
  integer, parameter :: g = 28
  integer g1
  integer gp
  integer gsave1
  integer, parameter :: h = 44
  logical havej
  integer hc
  integer hmi
  integer hpi
  integer hpm
  integer i
  integer, parameter :: ierr = 32
  integer, parameter :: ipiv0 = 60
  integer ipivi
  integer ipivk
  integer, parameter :: ipivot = 61
  integer irc
  integer iv(*)
  real j(nn,p)
  integer k
  integer, parameter :: kagqt = 35
  integer, parameter :: kalm = 36
  integer kind
  integer kl
  integer l
  integer, parameter :: lmat = 58
  integer m
  integer mm1
  integer mm1o2
  integer, parameter :: mode = 38
  integer, parameter :: nfgcal = 7
  integer pp1o2
  integer, parameter :: qtr = 49
  integer qtr1
  real r(n)
  integer, parameter :: rd = 51
  integer rd1
  integer, parameter :: rsave = 52
  integer, parameter :: savei = 54
  integer stp0
  integer stpi
  integer stpm
  integer, parameter :: switch = 12
  real t
  integer, parameter :: toobig = 2
  real v(*)
  integer, parameter :: w = 59
  integer w0
  integer w1
  real wk
  integer wl
  real x(p)
  integer, parameter :: xmsave = 49

  covirc = 4
  kind = iv(covreq)
  m = iv(mode)

  if ( m <= 0 ) then

    iv(kagqt) = -1

    if ( 0 < iv(kalm) ) then
      iv(kalm) = 0
    end if

    if ( 3 <= abs ( kind ) ) then

      rd1 = iv(rd)

      if ( iv(kalm) == -1 ) then
        qtr1 = iv(qtr)
        v(qtr1:qtr1+n-1) = r(1:n)
        w1 = iv(w) + p
        call qrfact ( nn, n, p, j, v(rd1), iv(ipivot), iv(ierr), 0, v(w1) )
        iv(kalm) = -2
      end if

      iv(covmat) = -1

      if ( iv(ierr) /= 0 ) then
        return
      end if

      cov = iv(lmat)
      hc = abs ( iv(h) )
      iv(h) = -hc
!
!  Set HC = R matrix from QRFACT.
!
      l = hc
      do i = 1, p
        if ( 1 < i ) then
          call vcopy ( i-1, v(l), j(1,i) )
        end if
        l = l + i - 1
        v(l) = v(rd1)
        l = l + 1
        rd1 = rd1 + 1
      end do

      go to 350

    end if

    v(fx) = v(f)
    k = iv(rsave)
    v(k:k+n-1) = r(1:n)

  end if

  if ( m <= p ) then

    if ( kind < 0 ) then
      go to 100
    end if
!
!  Compute finite-difference hessian using both function and
!  gradient values.
!
    gsave1 = iv(w) + p
    g1 = iv(g)
!
!  First call on COVCLC.  Set GSAVE = G, take first step.
!
    if ( m <= 0 ) then

      v(gsave1:gsave1+p-1) = v(g1:g1+p-1)
      iv(switch) = iv(nfgcal)

    else

      del = v(delta)
      x(m) = v(xmsave)
!
!  Handle oversize V(DELTA).
!
      if ( iv(toobig) /= 0 ) then

        if ( 0.0E+00 < del * x(m) ) then
          del = -0.5E+00 * del
          x(m) = x(m) + del
          v(delta) = del
          covirc = 2
          return
        end if

        iv(covmat) = -2
        go to 190

      end if

      cov = iv(lmat)
      gp = g1 + p - 1
!
!  Set G = ( G - GSAVE ) / DEL.
!
      do i = g1, gp
        v(i) = ( v(i) - v(gsave1) ) / del
        gsave1 = gsave1 + 1
      end do
!
!  Add G as new column to finite-difference hessian matrix.
!
      k = cov + ( m * ( m - 1 ) ) / 2
      l = k + m - 2
!
!  Set H(1:M-1,M) = 0.5 * (H(1:M-1,m) + G(1:M-1)).
!
      if ( m /= 1 ) then

        do i = k, l
          v(i) = 0.5E+00 * ( v(i) + v(g1) )
          g1 = g1 + 1
        end do

      end if
!
!  Add H(M:P,M) = G(M:P).
!
      l = l + 1
      do i = m, p
        v(l) = v(g1)
        l = l + i
        g1 = g1 + 1
      end do

    end if

    m = m + 1
    iv(mode) = m

    if ( p < m ) then
      go to 190
    end if
!
!  Choose next finite-difference step, return to get G there.
!
    del = v(delta0) * max ( 1.0E+00 / d(m), abs ( x(m) ) )
    if ( x(m) < 0.0E+00 ) then
      del = -del
    end if
    v(xmsave) = x(m)
    x(m) = x(m) + del
    v(delta) = del
    covirc = 2
    return
!
!  Compute finite-difference hessian using function values only.
!
 100  continue

    stp0 = iv(w) + p - 1
    mm1 = m - 1
    mm1o2 = m * mm1 / 2
!
!  First call on COVCLC.
!
    if ( m <= 0 ) then

      iv(savei) = 0

    else

      i = iv(savei)

      if ( i <= 0 ) then
!
!  Handle oversize step.
!
        if ( iv(toobig) /= 0 ) then

          stpm = stp0 + m
          del = v(stpm)
!
!  We already tried shrinking the step, so quit.
!
          if ( del * x(xmsave) <= 0.0E+00 ) then
            iv(covmat) = -2
            return
          end if
!
!  Try shrinking the step.
!
          del = -0.5E+00 * del
          x(m) = x(xmsave) + del
          v(stpm) = del
          covirc = 1
          return

        end if
!
!  Save F(X + STP(M)*E(M)) in H(P,M).
!
        pp1o2 = ( p * ( p - 1 ) ) / 2
        cov = iv(lmat)
        hpm = cov + pp1o2 + mm1
        v(hpm) = v(f)
!
!  Start computing row M of the finite-difference hessian H.
!
        hmi = cov + mm1o2
        hpi = cov + pp1o2

        do i = 1, mm1
          v(hmi) = v(fx) - (v(f) + v(hpi))
          hmi = hmi + 1
          hpi = hpi + 1
        end do

        v(hmi) = v(f) - 2.0E+00 * v(fx)
!
!  Compute function values needed to complete row M of H.
!
        i = 1

        iv(savei) = i
        stpi = stp0 + i
        v(delta) = x(i)
        x(i) = x(i) + v(stpi)
        if ( i == m ) then
          x(i) = v(xmsave) - v(stpi)
        end if
        covirc = 1
        return

      end if

      x(i) = v(delta)
!
!  Punt in the event of an oversize step.
!
      if ( iv(toobig) /= 0 ) then
        iv(covmat) = -2
        return
      end if
!
!  Finish computing H(M,I).
!
      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 <= m ) then
        iv(savei) = i
        stpi = stp0 + i
        v(delta) = x(i)
        x(i) = x(i) + v(stpi)
        if ( i == m ) then
          x(i) = v(xmsave) - v(stpi)
        end if
        covirc = 1
        return
      end if

      iv(savei) = 0
      x(m) = v(xmsave)

    end if

    m = m + 1
    iv(mode) = m
!
!  Prepare to compute row M of the finite-difference hessian H.
!  Compute the M-th step size STP(M), then return to obtain
!  F(X + STP(M)*E(M)), where E(M) = M-th standard unit vector.
!
    if ( m <= p ) then
      del = v(dltfdc) * max ( 1.0E+00 / d(m), abs(x(m)) )
      if (x(m) < 0.0E+00 ) then
        del = -del
      end if
      v(xmsave) = x(m)
      x(m) = x(m) + del
      stpm = stp0 + m
      v(stpm) = del
      covirc = 1
      return
    end if
!
!  Restore R, V(F), etc.
!
 190  continue

    k = iv(rsave)
    r(1:n) = v(k:k+n-1)
    v(f) = v(fx)

    if ( 0 <= kind ) then

      iv(nfgcal) = iv(switch)
      qtr1 = iv(qtr)
      v(qtr1:qtr1+n-1) = r(1:n)

      if ( 0 <= iv(covmat) ) then
        covirc = 3
      end if

      return
    end if

  end if

  cov = iv(lmat)
!
!  The complete finite-difference hessian is now stored at V(COV).
!  Use it to compute the requested covariance matrix.
!
!  Compute Cholesky factor C of H = C * C' and store it at V(HC).
!
  hc = cov

  if ( abs ( kind ) /= 2 ) then
    hc = abs ( iv(h) )
    iv(h) = -hc
  end if

  call lsqrt ( 1, p, v(hc), v(cov), irc )
  iv(covmat) = -1

  if ( irc /= 0 ) then
    return
  end if

  w1 = iv(w) + p

  if ( 1 < abs ( kind ) ) then
    go to 350
  end if
!
!  Covariance = SCALE * inverse ( H ) * (J' * J) * inverse ( H ).
!
  v(cov:cov+(p*(p+1))/2) = 0.0E+00
  havej = iv(kalm) == (-1)
!
!  HAVEJ = .true. means J is in its original form, while
!  HAVEJ = .false. means QRFACT has been applied to J.
!
  if ( havej ) then
    m = n
  else
    m = p
  end if
  w0 = w1 - 1
  rd1 = iv(rd)

  do i = 1, m
!
!  Set W = IPIVOT * (row I of R matrix from QRFACT).
!
    if ( .not. havej ) then

      v(w1:w1+p-1) = 0.0E+00
      ipivi = ipiv0 + i
      l = w0 + iv(ipivi)
      v(l) = v(rd1)
      rd1 = rd1 + 1

      do k = i+1, p
        ipivk = ipiv0 + k
        l = w0 + iv(ipivk)
        v(l) = j(i,k)
      end do
!
!  Set W = (row I of J).
!
    else

      l = w0
      do k = 1, p
        l = l + 1
        v(l) = j(i,k)
      end do

    end if
!
!  Set W = inverse ( H ) * W.
!
    call livmul ( p, v(w1), v(hc), v(w1) )
    call litvmu ( p, v(w1), v(hc), v(w1) )
!
!  Add W * W' to covariance matrix.
!
    kl = cov
    do k = 1, p
      l = w0 + k
      wk = v(l)
      do l = 1, k
        wl = w0 + l
        v(kl) = v(kl)  +  wk * v(wl)
        kl = kl + 1
      end do
    end do

  end do

  go to 380
!
!  The Cholesky factor C of the unscaled inverse covariance matrix
!  (or permutation thereof) is stored at V(HC).
!
!  Set C = inverse ( C ).
!
 350  continue

  call linvrt ( p, v(hc), v(hc) )
!
!  Set C = C' * C.
!
  call ltsqar ( p, v(hc), v(hc) )
!
!  C = permuted, unscaled covariance.
!  Set COV = IPIVOT * C * IPIVOT'.
!
  if ( hc /= cov ) then

    do i = 1, p
      m = ipiv0 + i
      ipivi = iv(m)
      kl = cov-1 + ( ipivi * (ipivi-1) ) / 2
      do k = 1, i
        m = ipiv0 + k
        ipivk = iv(m)
        l = kl + ipivk
        if ( ipivi < ipivk ) then
          l = l + ( (ipivk-ipivi) * (ipivk+ipivi-3) ) / 2
        end if
        v(l) = v(hc)
        hc = hc + 1
      end do
    end do

  end if

380  continue

  iv(covmat) = cov
!
!  Apply scale factor = (residual sum of squares) / max(1,n-p).
!
  t = v(f) / ( 0.5E+00 * real ( max ( 1, n-p ) ) )
  k = cov - 1 + ( p * ( p + 1 ) ) / 2

  v(cov:k) = t * v(cov:k)

  return
end
subroutine cpyasf ( m, x, lx, y, iy )

!*****************************************************************************80
!
!! CPYASF copies a symmetric matrix stored rowwise into rectangular storage.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iy
!        the first dimension of the matrix y.
!     integer lx
!        the length of symmetric matrix x, stored row wise.
!     integer m
!        the number of columns of data to be copied from matrix x.
!     real x(lx)
!        the matrix to be copied from.
!     real y(iy,m)
!        the matrix to be copied to.
!
  implicit none

  integer iy
  integer lx
  integer m

  integer i
  integer ij
  integer j
  real x(lx)
  real y(iy,m)

  do i = 1, m
     do j = 1, i
        ij = i*(i-1)/2 + j
        y(i,j) = x(ij)
        y(j,i) = y(i,j)
     end do
  end do

  return
end
subroutine cpymss ( n, m, x, ix, y, iy )

!*****************************************************************************80
!
!! CPYMSS copies an N by M matrix.
!
!  Modified:
!
!    28 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index value.
!     integer ix
!        the first dimension of the matrix x.
!     integer iy
!        the first dimension of the matrix y.
!     integer j
!        an index value.
!     integer m
!        the number of columns of data to be copied from matrix x.
!     integer n
!        the number of rows of data to be copied from matrix x.
!     real x(ix,m)
!        the matrix to be copied from.
!     real y(iy,m)
!        the matrix to be copied to.
!
  implicit none

  integer ix
  integer iy
  integer m

  integer n
  real x(ix,m)
  real y(iy,m)

  y(1:n,1:m) = x(1:n,1:m)

  return
end
subroutine cpyvii ( n, x, incx, y, incy )

!*****************************************************************************80
!
!! CPYVII copies an integer vector.
!
!  Discussion:
!
!    Copy integer x to integer y.
!    for i = 0 to n-1, copy  x(lx+i*incx) to y(ly+i*incy),
!    where lx = 1 if incx  >=  0, else lx = (-incx)*n, and ly is
!    defined in a similar way using incy.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index value.
!     integer incx
!        the increment for the matrix x.
!     integer incy
!        the increment for the matrix y.
!     integer n
!        the number of rows of data to be copied from matrix x.
!     integer x(n)
!        the matrix to be copied from.
!     integer y(n)
!        the matrix to be copied to.
!
  implicit none

  integer &
     incx,incy,n
!
!  array arguments
  integer &
     x(n),y(n)
!
!
  integer &
     i,ix,iy,m,ns

  if(n <= 0)return
  if(incx == incy) if(incx-1) 5,20,60
    5 continue
!
!  code for unequal or nonpositive increments.
!
  ix = 1
  iy = 1
  if(incx<0)ix = (-n+1)*incx + 1
  if(incy<0)iy = (-n+1)*incy + 1
  do i = 1,n
    y(iy) = x(ix)
    ix = ix + incx
    iy = iy + incy
  end do

  return
!
!  code for both increments equal to 1
!
!  clean-up loop so remaining vector length is a multiple of 7.
!
   20 m = mod(n,7)

  y(1:m) = x(1:m)

  if( n < 7 ) return

  do i = m+1,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)
  end do

  return
!
!  code for equal, positive, nonunit increments.
!
   60 continue
  ns = n*incx
      do i=1,ns,incx
      y(i) = x(i)
  end do
  return
end
function csevl ( x, cs, n )

!*****************************************************************************80
!
!! CSEVL evaluates a Chebyshev series.
!
!  Discussion:
!
!    Evaluate the N term Chebyshev series CS at X.  
!
!    Adapted from
!    r. broucke, 
!    algorithm 446, 
!    c.a.c.m., 16, 254 (1973).  
!
!    also see fox and parker, 
!    chebyshev polys in numerical analysis, 
!    oxford press, p.56.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!  Parameters:
!
!    x      value at which the series is to be evaluated.
!
!    cs     array of n terms of a chebyshev series.  in eval-
!        uating cs, only half the first coef is summed.
!
!    n      number of terms in array cs.
!
!    Output, real CSEVL, the value of the Chebyshev series.
!
  implicit none

  integer n

  real cs(n)
  real csevl
  real x

  real b0,b1,b2,twox
  integer i,ni

  if (n<1) call xerror ('csevl   number of terms le 0', 2,2)
  if (n > 1000) call xerror ('csevl   number of terms gt 1000', &
    3, 2)
  if (x<(-1.0) .or. x > 1.0) call xerror ( &
    'csevl   x outside (-1,+1)', 1, 1)

  b0 = 0.0
  b1 = 0.0
  b2 = 0.0
  twox = 2.0*x
  do i=1,n
    b2 = b1
    b1 = b0
    ni = n + 1 - i
    b0 = twox*b1 - b2 + cs(ni)
  end do

  csevl = 0.5 * (b0-b2)

  return
end
function d1mach ( i )

!*****************************************************************************80
!
!! D1MACH returns double precision real machine constants.
!
!  Discussion:
!
!    Assuming that the internal representation of a double precision real
!    number is in base B, with T the number of base-B digits in the mantissa,
!    and EMIN the smallest possible exponent and EMAX the largest possible 
!    exponent, then
!
!      D1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!      D1MACH(2) = B**EMAX*(1-B**(-T)), the largest magnitude.
!      D1MACH(3) = B**(-T), the smallest relative spacing.
!      D1MACH(4) = B**(1-T), the largest relative spacing.
!      D1MACH(5) = log10(B).
!
!  Modified:
!
!    24 April 2007
!
!  Author:
!
!    Phyllis Fox, Andrew Hall, Norman Schryer
!
!  Reference:
!
!    Phyllis Fox, Andrew Hall, Norman Schryer,
!    Algorithm 528:
!    Framework for a Portable Library,
!    ACM Transactions on Mathematical Software,
!    Volume 4, Number 2, June 1978, page 176-188.
!
!  Parameters:
!
!    Input, integer I, chooses the parameter to be returned.
!    1 <= I <= 5.
!
!    Output, real ( kind = 8 ) D1MACH, the value of the chosen parameter.
!
  implicit none

  real ( kind = 8 ) d1mach
  integer i

  if ( i < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'D1MACH - Fatal error!'
    write ( *, '(a)' ) '  The input argument I is out of bounds.'
    write ( *, '(a)' ) '  Legal values satisfy 1 <= I <= 5.'
    write ( *, '(a,i12)' ) '  I = ', i
    d1mach = 0.0D+00
    stop
  else if ( i == 1 ) then
    d1mach = 4.450147717014403D-308
  else if ( i == 2 ) then
    d1mach = 8.988465674311579D+307
  else if ( i == 3 ) then
    d1mach = 1.110223024625157D-016
  else if ( i == 4 ) then
    d1mach = 2.220446049250313D-016
  else if ( i == 5 ) then
    d1mach = 0.301029995663981D+000
  else if ( 5 < i ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'D1MACH - Fatal error!'
    write ( *, '(a)' ) '  The input argument I is out of bounds.'
    write ( *, '(a)' ) '  Legal values satisfy 1 <= I <= 5.'
    write ( *, '(a,i12)' ) '  I = ', i
    d1mach = 0.0D+00
    stop
  end if

  return
end
subroutine dckcnt ( xm, n, m, ixm, mdl, drv, par, npar, neta, ntau, &
  scale, lscale, nrow, nprt, hdr, page, wide, isubhd, hlfrpt, &
  prtfxd, ifixed, lifixd )

!*****************************************************************************80
!
!! DCKCNT controls the derivative checking process.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real d
!        the scalar in which row   nrowu   of the derivative
!        matrix with respect to the jth unknown parameter
!        is stored.
!     external drv
!        the name of the user supplied subroutine which computes the
!        analytic derivatives (jacobian matrix) of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer dtemp
!        the starting location in the work area in which
!        the array in which the analytic derivatives with
!        respect to each unknown parameter are stored.
!     real eta
!        the relative noise in the model.
!     real fplrs
!        the floating point largest relative spacing.
!     external hdr
!        the name of the routine which produces the heading
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifixd
!        the starting location in istak of
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer indxd, indxpv
!        the index in the work area of
!        the location of the value of the
!        derivative with respect to the jth parameter at row   nrowu
!        and of the location of the predicted value from the model for r
!        row   nrowu   .
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isubhd
!        an indicator value specifying subheadings to be printed by
!        routine hdr.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        an index variable.
!     integer lifixd
!        the length of the vector ifixed.
!     integer lmsg
!        the length of the vector msg.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer msg
!        the starting location in the work area of
!        an array used to store message parameters.
!     integer n
!        the number of observations of data.
!     integer nall0
!        the number of stack allocations on entry.
!     integer ndd
!        the number of decimal digits carried for a single
!        precision real number.
!     integer ndgt1
!        the number of reliable digits in the model used, either
!        set to the user supplied value of neta, or computed
!        by etamdl.
!     integer ndgt2
!        the actual number of digits of agreement used, either
!        set to the user supplied value of ntau, or computed
!        from ndgt1.
!     integer neta
!        the user supplied number of reliable digits in the model.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     integer nrow, nrowu
!        the user-supplied number of the row of the independent
!        variable array at which the derivative is to be checked,
!        and the number of the row actually used.
!     integer ntau
!        the number of digits of agreement required between the
!        numerical derivatives and the user supplied derivatives.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     integer partmp
!        the starting location in the work area of
!        the modified model parameters
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real pv
!        the scalar in which the predicted value from the model for
!        row   nrow   is stored.
!     integer pvtemp
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real scale(lscale)
!        the typical size of the unknown parameters.
!     real scl
!        the actual typical size used.
!     real tau
!        the agreement tolerance.
!     logical wide
!       the variable used to indicate whether the heading should
!        full width (true) or not (false).
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  integer &
     isubhd,ixm,lifixd,lscale,m,n,neta,npar,nprt,nrow,ntau
  logical &
     hlfrpt,page,prtfxd,wide
!
!  array arguments
  real &
     par(npar),scale(lscale),xm(ixm,m)
  integer &
     ifixed(lifixd)
!
!  subroutine arguments
  external drv,hdr,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     d,eta,fplrs,pv,scl,tau
  integer &
     dtemp,ifixd,ifp,indxd,indxpv,j,lmsg,msg,nall0,ndd,ndgt1, &
     ndgt2,nrowu,partmp,pvtemp
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external functions

  integer &
     stkget,stkst
  external stkget,stkst
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))

  nall0 = stkst(1)

  fplrs = epsilon ( fplrs )
!
!  select first row of independent variables which contains no zeros
!
  call setrow(nrow, xm, n, m, ixm, nrowu)
!
!  subdivide work area
!
  ifp = 3

  lmsg = npar + 1

  ifixd = stkget(npar,2)
  msg = stkget(lmsg,2)
  dtemp = stkget(n*npar,ifp)
  partmp = stkget(npar,ifp)
  pvtemp = stkget(n,ifp)

  if (ierr == 1) return
!
!  set up ifixd
!
  if (ifixed(1)<0) call setiv(istak(ifixd), npar, 0)
  if (ifixed(1) >= 0) call cpyvii(npar, ifixed, 1, istak(ifixd), 1)
!
!  set parameters necessary for the computations
!
  ndd = - int ( log10(fplrs) )

  if ((neta<2) .or. (neta > 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

  if ((ntau<1) .or. (ntau > (ndgt1-1)/2)) then
     ndgt2 = (ndgt1+3)/4
  else
     ndgt2 = ntau
  end if

  tau = 10.0e0**(-ndgt2)

  indxpv = pvtemp + nrowu - 1
!
!  compute predicted value of model using current parameter
!  estimates, and compute user-supplied derivative values
!
  call mdl(par, npar, xm, n, m, ixm, rstak(pvtemp))
  pv = rstak(indxpv)
  call drv(par, npar, xm, n, m, ixm, rstak(dtemp))

  istak(msg) = 0

  do j=1,npar

     if (scale(1) > 0.0e0) then
        scl = scale(j)
     else
        scl = par(j)
     end if
     if (scl == 0.0e0) scl = 1.0e0
!
!  call routine to check user supplied numerical derivatives
!  with respect to the jth parameter.
!
     indxd = dtemp - 1 + n*(j-1) + nrowu

     d = rstak(indxd)
     call dckmn(j, d, par, scl, npar, eta, tau, mdl, xm, n, nrowu, &
        m, ixm, pv, rstak(pvtemp), istak(msg), lmsg)

  end do

  if (istak(msg) >= 1) ierr = istak(msg) + 1
!
!  print results if they are desired
!
  hlfrpt = .false.

  if ((nprt /= 0) .or. (ierr /= 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

  call stkclr(nall0)

  return
end
subroutine dckcrv ( j, d, par, npar, eta, tau, mdl, xm, n, &
  nrow, m, ixm, pv, pvtemp, msg, lmsg, fd, parmx, pvpstp, stp )

!*****************************************************************************80
!
!! DCKCRV checks whether high curvature caused poor derivative approximation.
!
!  Discussion:
!
!    This routine checks whether high curvature could be the cause
!    of the disagreement between the numerical and analytic derivatives
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real curve
!        a measure of the curvature in the model.
!     real d
!        the scalar in which row   nrow   of the derivative
!        matrix with respect to the jth unknown parameter
!        is stored.
!     real eta
!        the relative noise in the model.
!     real fd
!        the forward difference quotient derivative with respect to the
!        jth parameter.
!     real fplrs
!        the floating point largest relative spacing.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the partial derivative being examined.
!     integer lmsg
!        the length of the vector msg.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer msg(lmsg)
!        an array used to store message parameters.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real parmx
!        the maximum of the current parameter estimate.
!     real pv
!        the scalar in which the predicted value from the model for
!        row   nrow   is stored.
!     real pvmcrv
!        the predicted value for row    nrow   of the model
!        based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)-stpcrv.
!     real pvpcrv
!        the predicted value for row    nrow   of the model
!        based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpcrv.
!     real pvpstp
!        the predicted value for row    nrow   of the model
!        based on the current parameter estimates
!        for all but the jth parameter value, which is par(j) + stp.
!     real pvtemp(n)
!        the vector of predicted values from the model.
!     real stp
!        the step size currently being examined for the finite differenc
!        derivative
!     real stpcrv
!        the step size selected to check for curvature in the model.
!     real tau
!        the agreement tolerance.
!     real temp
!        a temporary location in which the current estimate of the jth
!        parameter is stored.
!     real third
!        the value one third.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  real &
     d,eta,fd,parmx,pv,pvpstp,stp,tau
  integer &
     ixm,j,lmsg,m,n,npar,nrow
!
!  array arguments
  real &
     par(npar),pvtemp(n),xm(ixm,m)
  integer &
     msg(lmsg)
!
!  subroutine arguments
  external mdl
!
!
  real &
     curve,fplrs,pvmcrv,pvpcrv,stpcrv,temp,third
!
  fplrs = epsilon ( fplrs )

  third = 1.0e0/3.0e0

  stpcrv = (eta**third*parmx*sign(1.0e0,par(j))+par(j)) - par(j)

  temp = par(j)
  par(j) = temp + stpcrv
  call mdl(par, npar, xm, n, m, ixm, pvtemp)

  pvpcrv = pvtemp(nrow)

  par(j) = temp - stpcrv
  call mdl(par, npar, xm, n, m, ixm, pvtemp)
  par(j) = temp

  pvmcrv = pvtemp(nrow)
!
!  estimate curvature by second derivative of model with respect to
!  par(j)
!
  curve = ((pvpcrv+pvmcrv)-2*pv) / (stpcrv*stpcrv)
  curve = curve + (eta ** third) * (abs(pvpcrv) + &
     abs(pvmcrv) + 2.0e0 * abs(pv)) / (parmx * parmx)
!
!  compare numerical and analytical derivatives using a fudge
!  factor of 10.0e0.
!
  if (abs(curve*stp)*5.0e0<abs(fd-d)) then
!
!  curvature cannot account for discrepancy.
!  check if finite precision arithmetic could be the culprit.
!
     call dckfpa(j,d,par,npar,eta,tau,mdl,xm,n,nrow, &
        m,ixm,pv,pvtemp,msg,lmsg,fd,parmx,stp,pvpstp,curve)

  else
!
!  high curvature could be the problem.  try a smaller step size.
!  compute smaller stepsize
!
     stp = (2.0e0*tau*abs(d)*sign(1.0e0,par(j))/abs(curve)+par(j)) &
            - par(j)

     if (abs(stp) <= fplrs*abs(par(j))) then
!
!  new step size is too small to use.
!
        if (msg(1) == 0) msg(1) = 1
        msg(j+1) = 1
     else
!
!  try new step size
!
        temp = par(j)
        par(j) = temp + stp
        call mdl(par, npar, xm, n, m, ixm, pvtemp)
        par(j) = temp
        pvpstp = pvtemp(nrow)
!
!  compute the new numerical derivative
!
        fd = (pvpstp-pv)/stp
!
!  check whether the new numerical derivative is not ok
!
        if (abs(fd-d) > 2.0e0*tau*abs(d)) then
!
!  numerical derivative computed using new step size does
!  not agree with analytic derivative.
!
!  check if the problem could be the forward difference quotient
!  derivative.
!  (fudge factor is 2)
!
           if (abs(stp*(fd-d)) >= 2.0e0*eta*abs(pv+pvpstp)) then
!
!  finite precision could not be the culprit
!
              msg(1) = 2
              msg(j+1) = 2
           else
!
!  finite precision may be the culprit
!
              if (msg(1) == 0) msg(1) = 1
              msg(j+1) = 1
           end if
        end if
     end if
  end if

  return
end
subroutine dckdrv ( nmsub, ldstak, xm, n, m, ixm, mdl, &
     drv, par, npar, neta, ntau, scale, lscale, nrow, nprt )

!*****************************************************************************80
!
!! DCKDRV is the driver to the derivative checking routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     external dckhdr
!        the name of the routine which produces the heading
!     external drv
!        the name of the user supplied subroutine which computes the
!        analytic derivatives (jacobian matrix) of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the length of the vector ifixed.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations of data.
!     integer neta
!        the number of accurate digits in the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     integer nrow
!        the user-supplied number of the row of the independent
!        variable array at which the derivative is to be checked.
!     integer ntau
!        the number of digits of agreement required between the
!        numerical derivatives and the user supplied derivatives.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real scale(lscale)
!        the typical size of the unknown parameters.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real xm(ixm,m)
!        the independent variable array
!
  implicit none

  integer &
     ixm,ldstak,lscale,m,n,neta,npar,nprt,nrow,ntau
!
!  array arguments
  real &
     par(*),scale(*),xm(*)
  character &
     nmsub(6)*1
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     isubhd,lifixd
  logical &
     hlfrpt,page,prtfxd,wide
!
!  local arrays
  integer &
     ifixed(1)
!
!  external subroutines
  external dckcnt,dcker,dckhdr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     check for errors in input parameters
!
  call dcker(nmsub, n, m, ixm, npar, ldstak, scale, lscale)

  if (ierr /= 0) return

  page = .false.
  wide = .true.
  isubhd = 0

  prtfxd = .false.
  ifixed(1) = -1
  lifixd = 1

  call stkset(ldstak, 4)
!
!  pass control of derivative checking to dckcnt
!
  call dckcnt (xm, n, m, ixm, mdl, drv, par, npar, neta, &
     ntau, scale, lscale, nrow, nprt, dckhdr, page, wide, isubhd, &
     hlfrpt, prtfxd, ifixed, lifixd)

  return
end
subroutine dcker( nmsub, n, m, ixm, npar, ldstak, scale, lscale )

!*****************************************************************************80
!
!! DCKER does error checking for the derivative checking routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error(10)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index value.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 lixm(8), llds(8), lm(8), ln(8), lnpar(8), lscl(8),
!    *   lzero(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nv
!        the number of violations found by the scale checking routine.
!     real scale(lscale)
!        the typical size of the unknown parameters.
!
  implicit none

  integer &
     ixm,ldstak,lscale,m,n,npar
!
!  array arguments
  real &
     scale(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,ldsmin,nv
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,eisle,ervgt,ldscmp
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',' ',' ',' ',' '/
!
!  error checking
!
  error(1:10) = .false.

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 1, 1, head, error(1), ln)

  call eisge(nmsub, lm, m, 1, 1, head, error(2), lm)

  call eisge(nmsub, lixm, ixm, n, 3, head, error(3), ln)

  call eisle(nmsub, lnpar, npar, n, 2, head, error(4), ln)

  call ldscmp(5, 0, 2*npar+1, 0, 0, 0, 's', &
              n*npar + npar + n, ldsmin)

  if ((.not.error(1)) .and. (.not.error(4))) &
     call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(5), &
     llds)

  call ervgt(nmsub, lscl, scale, lscale, 0.0e0, 0, head, 6, nv, &
     error(9), lzero)

  do i=1,10
    if ( error(i) ) then
      ierr = 1
      return
    end if
  end do

  return
end
subroutine dckfpa( j, d, par, npar, eta, tau, mdl, xm, n, &
     nrow, m, ixm, pv, pvtemp, msg, lmsg, fd, parmx, stp, pvpstp, &
     curve )

!*****************************************************************************80
!
!! DCKFPA checks if arithmetic precision causes poor derivative approximation.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real curve
!        a measure of the curvature in the model.
!     real d
!        the scalar in which row   nrow   of the derivative
!        matrix with respect to the jth unknown parameter
!        is stored.
!     real eta
!        the relative noise in the model
!     real fd
!        the forward difference quotient derivative with respect to the
!        jth parameter
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the partial derivative being examined.
!     logical large
!        an indicator value indicating whether the recommended
!        increase in the step size would be greater than parmx.
!     integer lmsg
!        the length of the vector msg.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer msg(lmsg)
!        an array used to store message parameters.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real parmx
!        the maximum of the current parameter estimate and the
!        typical value of that parameter
!     real pv
!        the scalar in which the predicted value from the model for
!        row   nrow   is stored.
!     real pvpstp
!        the predicted value for row    nrow   of the model
!        based on the current parameter estimates
!        for all but the jth parameter value, which is par(j) + stp.
!     real pvtemp(n)
!        the vector of predicted values from the model.
!     real stp
!        the step size currently being examined for the finite differenc
!        derivative
!     real tau
!        the agreement tolerance.
!     real temp
!        a temporary location in which the current estimate of the jth
!        parameter is stored.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  real &
     curve,d,eta,fd,parmx,pv,pvpstp,stp,tau
  integer &
     ixm,j,lmsg,m,n,npar,nrow
!
!  array arguments
  real &
     par(npar),pvtemp(n),xm(ixm,m)
  integer &
     msg(lmsg)
!
!  subroutine arguments
  external mdl
!
!
  real &
     temp
  logical &
     large
!
!     check whether finite precision could be the problem
!
  if (abs(stp*(fd-d))  >=  &
     10.0e0*eta*(abs(pv)+abs(pvpstp))) then
!
!  discrepancy between numerical and analytical derivatives cannot
!  be accounted for by finite precision arithmetic
!
     msg(1) = 2
     msg(j+1) = 2
     return

  end if
!
!  finite precision arithmetic could be the problem.
!
!  try a larger step size
!
  stp = (eta*(abs(pv)+abs(pvpstp))*sign(1.0e0,par(j))/ &
     (tau*abs(d))+par(j)) - par(j)

  large = .false.

  if (abs(stp) > parmx) then
     stp = parmx*sign(1.0e0,par(j))
     large = .true.
  end if
!
!  calculate numerical derivative usng new, larger, stepsize
!
  temp = par(j)
  par(j) = par(j) + stp
  call mdl(par, npar, xm, n, m, ixm, pvtemp)
  par(j) = temp

  pvpstp = pvtemp(nrow)

  fd = (pvpstp-pv)/stp
!
!  check for agreement
!
  if ((abs(fd-d)) <= 2.0e0*tau*abs(d)) then
!
!  forward difference quotient and analytic derivatives agree for
!  this step size
!
     return
  end if
!
!  forward difference quotient and analytic derivatives still
!  disagree
!
!  check if curvature is the problem
!
  if (abs(curve*stp) < abs(fd-d) .and. (.not. large)) then
!
!  curvature couldnt be the culprit
!
         msg(1) = 2
         msg(j+1) = 2
         return
  else
!
!  curvature may be the culprit
!
         if (msg(1) == 0) msg(1) = 1
         if (large) msg(j+1) = 6
         if (.not. large) msg(j+1) = 1
         return
  end if

  return
end
subroutine dckhdr ( page, wide, isubhd )

!*****************************************************************************80
!
!! DCKHDR prints page headers for the derivative checking routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!       the variable used to indicate whether the heading should
!        full width (true) or not (false).
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide
!
!  external subroutines
  external versp

  if (page) write ( *, 1020)
  call versp(wide)
  if (page) write ( *,1000)
  if (.not.page) write ( *,1010)
  page = .true.

  if (isubhd == 0) return

  write ( *, 1030)

  return

 1000 format ('+derivative checking,', &
     ' continued')
 1010 format ('+', 23('*')/ ' * derivative checking *'/ 1x, 23('*'))
 1020 format ('1')
 1030 format (//' summary of initial conditions'/ 1x, 30('-'))
end
subroutine dckls1( n, m, ixm, par, npar, neta, ntau, nrow, scale, nprt )

!*****************************************************************************80
!
!! DCKLS1 sets up a problem for testing the step size selection family.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ixm
!        the first dimension of the independent variable array.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer neta
!        the number of reliable digits in the model.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     integer ntau
!        the number of digits of agreement required between the
!        numerical derivatives and the user supplied derivatives.
!     real par(10)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real scale(10)
!        a value to indicate use of the default values of
!        the typical size of the unknown parameters.
!       
  implicit none

  integer &
     ixm,m,n,neta,npar,nprt,nrow,ntau
!
!  array arguments
  real &
     par(10),scale(10)
!
  par(1) = 1.0e0
  par(2) = 3.125e0
  par(3) = 1.0e0
  par(4) = 2.0e0

  n = 101
  m = 1
  ixm = 200
  npar = 4
  scale(1:10) = 1.0e0
  scale(2) = 0.01e0
  neta = 0
  ntau = 0
  nrow = 1
  nprt = 1

  return
end
subroutine dcklsc ( xm, n, m, ixm, mdl, drv, par, npar, ldstak, &
     neta, ntau, scale, nrow, nprt )

!*****************************************************************************80
!
!! DCKLSC is the user routine for comparing analytic and numeric derivatives.
!
!  Discussion:
!
!    This is the user callable subroutine for checking user supplied
!    analytic derivatives against numerical derivatives
!    for the nonlinear least squares routines (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     external drv
!        the name of the user supplied subroutine which computes the
!        analytic derivatives (jacobian matrix) of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations of data.
!     integer neta
!        the number of accurate digits in the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     integer ntau
!        the number of digits of agreement required between the
!        numerical derivatives and the user supplied derivatives.
!     real par(npar)
!        the array in which the current estimates of the
!        parameters are stored.
!     real scale(npar)
!        the typical size of the parameters.
!     real xm(ixm,m)
!        the independent variable.
!
  implicit none

  integer &
     ixm,ldstak,m,n,neta,npar,nprt,nrow,ntau
!
!  array arguments
  real &
     par(*),scale(*),xm(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer lscale
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external dckdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'd','c','k','l','s','c'/

  lscale = npar
!
!  pass control of derivative checking to dckdrv
!
  call dckdrv(nmsub, ldstak, xm, n, m, ixm, mdl, drv, par, npar, &
     neta, ntau, scale, lscale, nrow, nprt)

  return
end
subroutine dckls ( xm, n, m, ixm, mdl, drv, par, npar, ldstak )

!*****************************************************************************80
!
!! DCKLS is the user routine for comparing analytic and numeric derivatives.
!
!  Discussion:
!
!    This is the user callable subroutine for checking user supplied
!    analytic derivatives against numerical derivatives
!    for the nonlinear least squares routines (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     external drv
!        the name of the user supplied subroutine which computes the
!        analytic derivatives (jacobian matrix) of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations of data.
!     integer neta
!        the number of accurate digits in the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     integer ntau
!        the number of digits of agreement required between the
!        numerical derivatives and the user supplied derivatives.
!     real par(npar)
!        the array in which the current estimates of the
!        parameters are stored.
!     real scale(1)
!        a dummy array, indicating use of default values for
!        the typical size of the parameters.
!     real xm(ixm,m)
!        the independent variable matrix.
!
  implicit none

  integer &
     ixm,ldstak,m,n,npar
!
!  array arguments
  real &
     par(*),xm(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer lscale,neta,nprt,nrow,ntau
!
!  local arrays
  real &
     scale(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external dckdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'd','c','k','l','s',' '/
!
!  set default values
!
  neta = 0
  ntau = 0
  scale(1) = 0.0e0
  lscale = 1
  nprt = 1
  nrow = 0
!
!  pass control of derivative checking to dckdrv
!
  call dckdrv(nmsub, ldstak, xm, n, m, ixm, mdl, drv, par, npar, &
     neta, ntau, scale, lscale, nrow, nprt)

  return
end
subroutine dckmn ( j, d, par, scale, npar, eta, tau, mdl, xm, &
     n, nrow, m, ixm, pv, pvtemp, msg, lmsg )

!*****************************************************************************80
!
!! DCKMN is the main routine for checking analytic versus numeric derivatives.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real d
!        the scalar in which row   nrow   of the derivative
!        matrix with respect to the jth unknown parameter
!        is stored.
!     real eta
!        the relative noise in the model
!     real fd
!        the forward difference quotient derivative with respect to the
!        jth parameter
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the partial derivative being examined.
!     integer lmsg
!        the length of the vector msg.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer msg(lmsg)
!        an array used to store message parameters.
!     integer n
!        the number of observations
!     integer npar
!        the number of unknown parameters in the model.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real parmx
!        the maximum of the current parameter estimate and the
!        typical value of that parameter
!     real pv
!        the scalar in which the predicted value from the model for
!        row   nrow   is stored.
!     real pvpstp
!        the predicted value for row    nrow   of the model
!        based on the current parameter estimates
!        for all but the jth parameter value, which is par(j) + stp.
!     real pvtemp(n)
!        the vector of predicted value from the model.
!     real scale
!        the typical size of the jth parameter.
!     real stp
!        the step size currently being examined for the finite differenc
!        derivative
!     real tau
!        the agreement tolerance.
!     real temp
!        a temporary location in which the current estimate of the jth
!        parameter is stored.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  real &
     d,eta,pv,scale,tau
  integer &
     ixm,j,lmsg,m,n,npar,nrow
!
!  array arguments
  real &
     par(npar),pvtemp(n),xm(ixm,m)
  integer &
     msg(lmsg)
!
!  subroutine arguments
  external mdl

  real &
     fd,parmx,pvpstp,stp,temp
!
!  calculate the jth partial derivative using forward difference
!  quotients and decide if it agrees with user supplied values
!
  msg(j+1) = 0

  parmx = max(abs(par(j)),abs(scale))
  if (parmx == 0.0e0) parmx = 1.0e0
!
!  compute initial step size
!
  stp = (sqrt(eta)*parmx*sign(1.0e0,par(j))+par(j)) - par(j)
!
!  compute predicted values
!
  temp = par(j)
  par(j) = par(j) + stp
  call mdl(par, npar, xm, n, m, ixm, pvtemp)
  par(j) = temp

  pvpstp = pvtemp(nrow)

  fd = ( pvpstp - pv ) / stp
!
!  check for disagreement
!
  if ( abs(fd-d) <= tau*abs(d) ) then
!
!  numerical and analytic derivatives agree
!
!  check if analytic derivative is identically zero, indicating
!  the possibility that the derivative should be rechecked at
!  another point.
!
    if (d /= 0.0e0) return
!
!  jth analytic and numerical derivatives both are zero.
!
    if (msg(1) == 0) msg(1) = 1
    msg(j+1) = 3
    return

  end if
!
!  numerical and analytic derivatives disagree.  check why.
!
  if (d == 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

  return
end
subroutine dckout ( xm, ixm, n, m, nrow, neta, ntau, npar, msg, &
     lmsg, par, scale, lscale, hdr, page, wide, isubhd, prtfxd, ifixd )

!*****************************************************************************80
!
!! DCKOUT prints results from the derivative checking routine.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     character*1 blank
!        the character blank.
!     character*1 fixed(3)
!        the characters used to label the parameters fixed or not.
!     logical ftnote(6)
!        the array which controls printing of footnotes.
!     external hdr
!        the name of the routine which produces the heading
!     integer i
!        an index variable
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixd(i) /= 0, then par(i) will be optimized.  if
!        ifixd(i) == 0, then par(i) will be held fixed.
!     integer imax, imin
!        the largest and smallest index value to be printed on each
!        line.
!     integer index
!        the index value to be printed.
!     integer isubhd
!        an indicator value specifying subheadings to be printed by
!        routine hdr.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        an index variable.
!     integer k
!        an index variable.
!     integer lmsg
!        the length of the vector msg.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     integer msg(lmsg)
!        an array used to store message parameters.
!     integer neta
!        the number of reliable digits in the model.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nperl
!        the number of values to be printed per line.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     integer ntau
!        the number of digits of agreement required between the
!        approximated derivatives and the user-supplied derivatives.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real scale(lscale)
!        the typical size of the unknown parameters.
!     logical wide
!       the variable used to indicate whether the heading should
!        full width (true) or not (false).
!     real xm(ixm,m)
!        the independent variable.
!
  implicit none

  integer &
     isubhd,ixm,lmsg,lscale,m,n,neta,npar,nrow,ntau
  logical &
     page,prtfxd,wide
!
!  array arguments
  real &
     par(npar),scale(lscale),xm(ixm,m)
  integer &
     ifixd(npar),msg(lmsg)
!
!  subroutine arguments
  external hdr

  integer &
     i,imax,imin,index,j,k,nperl
  character &
     blank*1
!
!  local arrays
  logical &
     ftnote(6)
  character &
     fixed(3)*1

  data blank /' '/
!
!  initialize array fixed
!
  fixed(1:3) = blank

  call hdr(page, wide, isubhd)
!
!  set up for footnotes
!
  ftnote(1:6) = .false.

  if ( 0 < msg(1) ) then

    do i=1,npar

      if ((msg(i+1) == 0) .or. (msg(i+1) == 2)) then
        cycle
      end if

      k = msg(i+1) - 2
      if (k == -1) k = 5
      ftnote(1) = .true.
      ftnote(k+1) = .true.

    end do

  end if
!
!  print report
!
  write ( *,1000)
  if ( ftnote(1) ) then
    write ( *,1040)
  end if

  if ( prtfxd ) then
    write ( *,1160)
  else
    write ( *,1170)
  end if

  if ( 0.0E+00 < scale(1) ) then

    do i=1,npar
      if (prtfxd) call fixprt(ifixd(i), fixed)
      k = msg(i+1) - 2
      if (k == -1) k = 5
      if (k == -2) write ( *,1010) i, (fixed(j),j=1,3), par(i), &
        scale(i)
      if (k == 0) write ( *,1020) i, (fixed(j),j=1,3), par(i), &
        scale(i)
      if (k >= 1) write ( *,1030) i, (fixed(j),j=1,3), par(i), &
        scale(i), k
    end do

  else

    do i=1,npar
      if (prtfxd) call fixprt(ifixd(i), fixed)
      k = msg(i+1) - 2
      if (k == -1) k = 5
      if (k == -2) write ( *,1180) i, (fixed(j),j=1,3), par(i)
      if (k == 0) write ( *,1190) i, (fixed(j),j=1,3), par(i)
      if (k >= 1) write ( *,1200) i, (fixed(j),j=1,3), par(i), k
    end do

  end if
!
!  print footnotes
!
  if ( ftnote(1) ) then
    write ( *,1060)
    if (ftnote(2)) write ( *,1070)
    if (ftnote(3)) write ( *,1080)
    if (ftnote(4)) write ( *,1090)
    if (ftnote(5)) write ( *,1100)
    if (ftnote(6)) write ( *,1050)
  end if

  write ( *,1110) neta
  write ( *,1120) ntau
!
!  print out row of independent variable which was checked.
!
  write ( *,1130) nrow
  nperl = 7

  do i=1,m,nperl
     imin = i
     imax = min(i+nperl-1,m)
     write ( *,1140) (index,index=imin,imax)
     write ( *,1150) (xm(nrow,index),index=imin,imax)
  end do

  write ( *,1210) n

  return

 1000 format (//)
 1010 format (1x, i3, 5x, 3a1, 2g17.8, 10x, 'ok')
 1020 format (1x, i3, 5x, 3a1, 2g17.8, 7x, 'incorrect')
 1030 format (1x, i3, 5x, 3a1, 2g17.8, 5x, 'questionable (', i1, ')')
 1040 format (62x, '*')
 1050 format (/'  (5) user-supplied and approximated derivatives', &
     ' disagree, but',/,5x, ' approximated derivative is questiona', &
     'hble because', ' ratio'/5x, ' of relative curvature to rela', &
     'tive slope is too', ' high.')
 1060 format (/' * numbers in parentheses refer to the following notes.')
 1070 format (/'  (1) user-supplied and approximated derivatives', &
     ' agree, but'/5x, ' both are zero.  recheck at another row.')
 1080 format (/'  (2) user-supplied and approximated derivatives', &
     ' may agree, but'/5x, ' user-supplied derivative is identic', &
     'ally zero', ' and approximated'/5x, ' derivative is only a', &
     'pproximately zero.', '  recheck at another row.')
 1090 format (/'  (3) user-supplied and approximated derivatives', &
     ' disagree, but'/5x, ' user-supplied derivative is identica', &
     'lly zero.', '  recheck at'/5x, ' another row.')
 1100 format (/'  (4) user-supplied and approximated derivatives', &
     ' disagree, but'/5x, ' approximated derivative is questiona', &
     'ble because', ' either ratio'/5x, ' of relative curvature', &
     ' to relative slope is too', ' high, or'/5x, ' scale(k) is ', &
     'wrong.')
 1110 format (/' number of reliable digits in model results', 25x, &
     '(neta)', 1x, i5)
 1120 format (/' number of digits in derivative checking', ' agreemen', &
     't tolerance', 8x, '(ntau)', 1x, i5)
 1130 format (/' row number at which derivatives were checked', 23x, &
     '(nrow)', 1x, i5/'   -values of the independent variables at', &
     ' this row')
 1140 format (10x, 'index', i5, 6i15)
 1150 format (10x, 'value', 7(1x, g14.7)/)
 1160 format (52x, 'derivative'/7x, 'parameter starting value', 6x, &
     'scale', 10x, 'assessment'/1x, 'index', 2x, 'fixed', 6x, &
     '(par)', 12x, '(scale)'/)
 1170 format (17x, 'parameter', 26x, 'derivative'/15x, 'starting val', &
     'ue', 8x, 'scale', 10x, 'assessment'/1x, 'index', 13x, &
     '(par)', 12x, '(scale)'/)
 1180 format (1x, i3, 5x, 3a1, g17.8, 7x, 'default', 13x, 'ok')
 1190 format (1x, i3, 5x, 3a1, g17.8, 7x, 'default', 10x, 'incorrect')
 1200 format (1x, i3, 5x, 3a1, g17.8, 7x, 'default', 8x, 'questionabl', &
     'e (', i1, ')')
 1210 format (/' number of observations', 48x, '(n)', 1x, i5)
end
subroutine dckzro ( j, par, npar, mdl, xm, n, nrow, m, ixm, pv, &
     pvtemp, msg, lmsg, fd, parmx, pvpstp, stp )

!*****************************************************************************80
!
!! DCKZRO rechecks derivative errors where the analytic derivative is zero.
!
!  Discussion:
!
!    This routine rechecks the derivatives in the case where the finite
!    difference derivative disagrees with the analytic derivative and t
!    analytic derivative is zero.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real cd
!        the central difference quotient derivative with
!        respect to the jth parameter.
!     real fd
!        the forward difference quotient derivative with respect to the
!        jth parameter.
!     real fplrs
!        the floating point largest relative spacing.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the partial derivative being examined.
!     integer lmsg
!        the length of the vector msg.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer msg(lmsg)
!        an array used to store message parameters.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real parmx
!        the maximum of the current parameter estimate and the typical
!        value of that parameter.
!     real pv
!        the scalar in which the predicted value from the model for
!        row   nrow   is stored.
!     real pvmstp
!        the predicted value for row    nrow   of the model
!        based on the current parameter estimates
!        for all but the jth parameter value, which is par(j) - stp.
!     real pvpstp
!        the predicted value for row    nrow   of the model
!        based on the current parameter estimates
!        for all but the jth parameter value, which is par(j) + stp.
!     real pvtemp(n)
!        the vector of predicted values from the model.
!     real stp
!        the step size currently being examined for the finite differenc
!        derivative
!     real temp
!        a temporary location in which the current estimate of the jth
!        parameter is stored.
!     real third
!        the value 1/3.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  real &
     fd,parmx,pv,pvpstp,stp
  integer &
     ixm,j,lmsg,m,n,npar,nrow
!
!  array arguments
  real &
     par(npar),pvtemp(n),xm(ixm,m)
  integer &
     msg(lmsg)
!
!  subroutine arguments
  external mdl
!
!
  real &
     cd,fplrs,pvmstp,temp,third

  fplrs = epsilon ( fplrs )
!
!  recalculate numerical derivative using central difference and step
!  size of 2*stp
!
  temp = par(j)
  par(j) = par(j) - stp
  call mdl(par, npar, xm, n, m, ixm, pvtemp)
  par(j) = temp

  pvmstp = pvtemp(nrow)

  cd = (pvpstp-pvmstp)/(2.0e0*stp)
!
!  check for disagreement
!
!  numerical and analytic derivatives now agree, but both equal zero,
!  indicating that derivatives should be rechecked at another point.
!
  if ( cd == 0.0e0 ) then
    if (msg(1) == 0) msg(1) = 1
    msg(j+1) = 3
    return
  end if
!
!  numerical and analytic derivative still do not agree.
!
!  check if numerical derivative is close to zero.
!
  third = 1.0e0/3.0e0
!
!  numerical derivative is close to zero
!
  if (min(abs(cd), abs(fd))*parmx <= abs(pv*fplrs**third)) then
    if (msg(1) == 0) msg(1) = 1
    msg(j+1) = 4
!
!  numerical derivative not close to zero
!
  else
    msg(1) = 2
    msg(j+1) = 5
  end if

  return
end
subroutine dcoef ( ndf, nd, iod, npardf, pardf, mbo, work )

!*****************************************************************************80
!
!! DCOEF expands a difference filter.
!
!  Discussion:
!
!    This routine expands the difference filter specified by ndf,
!    iod and nd into pardf.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iod(ndf)
!        the order of each of the difference factors.
!     integer k
!        an index variable.
!     integer kk
!        an index variable.
!     integer l
!        an index variable.
!     integer mbo
!        the maximum back order operator.
!     integer nd(ndf)
!        the number of times each difference factor is to be applied.
!     integer ndf
!        the number of difference factors
!     integer npardf
!        the order of the expanded difference filter.
!     integer ntimes
!        the number of times a given difference factor is to be applied.
!     integer nwork1
!        the number of terms in the first column of work.
!     integer nwork2
!        the number of terms in the second column of work
!     real pardf(mbo)
!        the vector containing the difference filter parameters.
!     real work(mbo,2)
!        a work array necessary to expand the difference filter.
!
  implicit none

  integer &
     mbo,ndf,npardf
!
!  array arguments
  real &
     pardf(*),work(*)
  integer &
     iod(*),nd(*)
!
!
  integer &
     k,kk,l,ntimes,nwork1,nwork2
!
!  external functions
  integer &
     nchose
  external nchose
!
!  external subroutines
  external multbp

  npardf = 0

  do l = 1, ndf

    if ( nd(l)  ==  0 ) then
      cycle
    end if

    ntimes = nd(l)
    nwork1 = iod(l) * nd(l)
    work(1:nwork1) = 0.0e0

    do k = 1, ntimes
      kk = k * iod(l)
      work(kk) = real ( ((-1)**(k+1)) * nchose(ntimes, k) )
    end do

    nwork2 = nwork1 + npardf

    call multbp (work(1), nwork1, pardf, npardf, work(mbo+1), &
      nwork2, mbo)

  end do

  return
end
subroutine demdrv ( y, n, fd, fc, k, hlp, ampl, phase, iphase, &
     ndem, nprt, nmsub )

!*****************************************************************************80
!
!! DEMDRV is the driver routine to demodulate a series.
!
!  Discussion:
!
!    This is the driver routine to demodulate series
!    y at frequency fd, to apply a low pass filter with cutoff
!    frequency fc, and to extract the amplitude and phase components
!    of the resulting filtered series .
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!  Parameters:
!
!     real ampl(n)
!        the array in which the amplitudes are stored.
!     real fc
!        the cutoff frequency used for the low pass filter.
!     real fd
!        the demodulation frequency.
!     real hlp(k)
!        the array in which the low pass filter coefficients are
!        stored.
!     integer k
!        the user supplied number of terms to be used for the low
!        pass filter.
!     integer n
!        the number of observations.
!     integer ndem
!        the number of values in the demodulated series, i.e., in
!        the amplitude and phase arrays.
!     character*1 nmsub(6)
!        the name of the calling subroutine.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of nprt
!        is zero, no output is given, otherwise output is provided.
!     real phase(iphase,2)
!        the array contianing the primary and secondary phase estimates.
!     real y(n)
!        the input array containing the observed series.
!
  implicit none

  real &
     fc,fd
  integer &
     iphase,k,n,ndem,nprt
!
!  array arguments
  real &
     ampl(n),hlp(k),phase(iphase,2),y(n)
  character &
     nmsub(6)*1
!
!  external subroutines
  external demodu,demord,demout,fltsl,lpflt,polar
!
  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)

  call polar (ampl, phase, ndem)

  if (nprt == 0) return

  call demord (phase, phase(1,2), ndem, n)
  call demout (fd, fc, k, ampl, phase, iphase, ndem, nmsub)

  return
end
subroutine demod ( y, n, fd, fc, k, ldstak )

!*****************************************************************************80
!
!! DEMOD demodulates a series at a given frequency.
!
!  Discussion:
!
!    This is the user callable routine to demodulate series
!    y at frequency fd, to apply a low pass filter with cutoff
!    frequency fc, and to extract the amplitude and phase components
!    of the resulting filtered series (short call).
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!  Parameters:
!
!     integer ampl
!        the starting location in rstak/dstak of
!        the array in which the amplitudes are stored.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03, err04, err05, err06, err07
!        values indicating whether an error was detected (true) or not
!        (false).
!     real fc
!        the cutoff frequency used for the low pass filter.
!     real fd
!        the demodulation frequency.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer hlp
!        the starting location in rstak/dstak of
!        the array in which the low pass filter coefficients are
!        stored.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer k
!        the user supplied number of terms to be used for the low
!        pass filter.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 lfc(8), lfd(8), lk(8), lkin(8), llds(8), ln(8),
!    *  lnm1(8), lone(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer n
!        the number of observations.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     integer ndem
!        the number of values in the demodulated series, i.e., in
!        the amplitude and phase arrays.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer phase
!        the starting locations in rstak/dstak of
!        the array containing the primary and secondary phase estimates.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real temp
!        a temporary variable used for type conversion.
!     real y(n)
!        the input array containing the observed series.
!
  implicit none

  real &
     fc,fd
  integer &
     k,ldstak,n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     temp
  integer &
     ampl,hlp,ifp,ldsmin,nall0,ndem,phase
  logical &
     err01,err02,err03,err04,err05,err06,err07,head
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external demdrv,eisge,eisii,eriodd,ersii,erslfs,ldscmp, &
     stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' '/
!
!  Perform error checking on input data.
!
  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  call ersii(nmsub, lfd, fd, &
             0.0e0, 0.5e0, 2, head, err02, lfd, lfd)

  err03 = .true.
  if (.not. err01) &
    call eisii(nmsub, lk, k, 1, n-1, 1, head, err03, lone, lnm1)

  call eriodd(nmsub, lk, k, 1, head, err04)

  err05 = .true.
  if ((.not. err02) .and. (.not. err03) .and. (.not. err04)) then
     temp = real ( k )
     call ersii(nmsub, lfc, fc, 1.0e0/temp, fd, 1, head, err05, &
                lkin, lfd)
  end if

  err06 = .true.
  if ((.not. err03) .and. (.not. err04) .and. (.not. err05)) &
     call erslfs(nmsub, fc, k, head, err06)

  if (err01 .or. err06) then
    ierr = 1
    return
  end if

  call ldscmp ( 3, 0, 0, 0, 0, 0, 's', k + 3*n, ldsmin )

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err07, llds)

  if (err02 .or. err03 .or. err04 .or. err05 .or. err07) then
    ierr = 1
    return
  end if

  call stkset (ldstak, 4)
  nall0 = stkst(1)

  ifp = 3

  ampl = stkget(n, ifp)
  phase = stkget(2*n, ifp)
  hlp = stkget(k, ifp)

  if (ierr == 1) then
    ierr = 1
    return
  end if

  call demdrv(y, n, fd, fc, k, rstak(hlp), rstak(ampl), &
     rstak(phase), n, ndem, 1, nmsub)

  call stkclr(nall0)

  if (ierr == 1) then
    ierr = 1
    return
  end if

  return
end
subroutine demods ( y, n, fd, fc, k, ampl, phas, ndem, nprt, ldstak )

!*****************************************************************************80
!
!! DEMODS demodulates a series at a given frequency.
!
!  Discussion:
!
!    This is the user callable routine to demodulate series
!    y at frequency fd, to apply a low pass filter with cutoff
!    frequency fc, and to extract the amplitude and phase components
!    of the resulting filtered series (long call).
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!  Parameters:
!
!     real ampl(n)
!        the array in which the amplitudes are stored.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03, err04, err05, err06, err07
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real fc
!        the cutoff frequency used for the low pass filter.
!     real fd
!        the demodulation frequency.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer hlp
!        the starting location in rstak/dstak of
!        the array in which the low pass filter coefficients are
!        stored.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer io
!        a variable used to determine the amount of storage required
!        based on printed output requested.
!     integer k
!        the user supplied number of terms to be used for the low
!        pass filter.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 lfc(8), lfd(8), lk(8), lkin(8), llds(8), ln(8),
!    *  lnm1(8), lone(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer n
!        the number of observations.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     integer ndem
!        the number of values in the demodulated series, i.e., in
!        the amplitude and phase arrays.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be given, where if the value of nprt
!        is zero, no output is given, otherwise output is provided.
!     real phas(n)
!        the array in which the primary phase estimates are returned.
!     integer phase
!        the starting location in rstak/dstak of
!        the array containing the primary and secondary phase estimates.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real temp
!        a temporary variable used for type conversion.
!     real y(n)
!        the input array containing the observed series.
!
  implicit none

  real &
     fc,fd
  integer &
     k,ldstak,n,ndem,nprt
!
!  array arguments
  real &
     ampl(*),phas(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     temp
  integer &
     hlp,io,ldsmin,nall0,phase
  logical &
     err01,err02,err03,err04,err05,err06,err07,head
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external demdrv,eisge,eisii,eriodd,ersii,erslfs,ldscmp, &
     scopy,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' '/
!
!  perform error checking on input data.
!
  ierr = 0
  head = .true.

  if (nprt == 0) then
    io = 0
  else
    io = 1
  end if

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  call ersii(nmsub, lfd, fd, 0.0e0, 0.5e0, 2, head, err02, lfd, lfd)

  err03 = .true.
  if (.not. err01) &
    call eisii(nmsub, lk, k, 1, n-1, 1, head, err03, lone, lnm1)

  call eriodd(nmsub, lk, k, 1, head, err04)

  err05 = .true.
  if ((.not. err02) .and. (.not. err03) .and. (.not. err04)) then
     temp = real ( k )
     call ersii(nmsub, lfc, fc, 1.0e0/temp, fd, 1, head, err05, lkin, lfd)
  end if

  err06 = .true.
  if ((.not. err03) .and. (.not. err04) .and. (.not. err05)) &
     call erslfs(nmsub, fc, k, head, err06)

  if (err01 .or. err06) then
    ierr = 1
    return
  end if

  call ldscmp(2, 0, 0, 0, 0, 0, 's', k + io*2*n, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err07, llds)

  if (err02 .or. err03 .or. err04 .or. err05 .or. err07) then
    ierr = 1
    return
  end if

  call stkset (ldstak, 4)
  nall0 = stkst(1)

  hlp = stkget(k, 3)
  if (nprt == 0) then
     phase = 1
  else
     phase = stkget(2*n, 3)
  end if

  if (ierr == 1) then
    ierr = 1
    return
  end if

  if (nprt  /=  0) then

     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

  call stkclr(nall0)

  if (ierr == 1) then
    ierr = 1
    return
  end if

  return
end
subroutine demodu ( y, n, fd, ampl, phas )

!*****************************************************************************80
!
!! DEMODU demodulates a series at a given frequency.
!
!  Discussion:
!
!    This routine demodulates the series y at frequency
!    fd.  the real and imaginary parts of the demodulated
!    series are returned in ampl and phas, respectively.
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!  Parameters:
!
!     real ampl(n)
!        the array in which the amplitudes are stored.
!     real arg
!        a value used in computing the demodulated series.
!     real fd
!        the demodulation frequency.
!     integer i
!        an indexing variable.
!     integer n
!        the number of observations in the series being demodulated.
!     real phas(n)
!        the arrays containing the primary phase estimates.
!     real pi
!        the value of pi.
!     real y(n)
!        the input array array containing the observed series.
!
  implicit none

  integer n

  real ampl(n)
  real arg
  real fd
  integer i
  real phas(n)
  real pi
  real y(n)

  call getpi(pi)

  do i = 1, n
     if (fd == 0.25e0) then
        ampl(i) = 0.0e0
        phas(i) = -2.0e0*y(i)
     else if (fd == 0.5e0) then
        ampl(i) = -2.0e0*y(i)
        phas(i) = 0.0e0
     else
        arg = real (i-1) * fd * 2.0e0 * pi
        ampl(i) = y(i)*cos(arg)*2.0e0
        phas(i) = -y(i)*sin(arg)*2.0e0
     end if
  end do

  return
end
subroutine demord ( phas1, phas2, ndem, n )

!*****************************************************************************80
!
!! DEMORD sets up the data for the phase plots.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer n
!        the number of observations in the series being demodulated.
!     integer ndem
!        the number of values in the demodulated series, i.e., in
!        the amplitude and phase arrays.
!     real phas1(n), phas2(n)
!        the arrays containing the primary and secondary phase
!        estimates, respectively.
!
  implicit none

  integer &
     n,ndem
!
!  array arguments
  real &
     phas1(n),phas2(n)
!
!
  real &
     pi
  integer &
     i
!
!  external subroutines
  external getpi

  call getpi(pi)

  do i = 1, ndem
     phas2(i) = 0.0e0
     if (phas1(i) > 0.0e0) phas2(i) = phas1(i) - 2.0e0*pi
     if (phas1(i) < 0.0e0) phas2(i) = phas1(i) + 2.0e0*pi
  end do

  return
end
subroutine demout ( fd, fc, k, ampl, phase, iphase, ndem, nmsub )

!*****************************************************************************80
!
!! DEMOUT prints output for the time series demodulation routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ampl(ndem)
!        the array in which the amplitudes of the demodulated series
!        are stored.
!     logical error
!        an error flag
!     real fc, fd
!        the cutoff frequency and the demodulation frequency.
!     integer ierr
!        the error flag
!     integer isym(1)
!        a dummy array.
!     integer k
!        the number of terms in the low pass filter used to smooth
!        the demodulated series.
!     integer ndem
!        the number of values in the demodulated series.
!     character*1 nmsub(6)
!        the name of the calling subroutine
!     real phase(iphase,2)
!        the array containing the primary and secondary phase values.
!     real pi
!        the value of pi.
!     real ymn, ymx
!
  implicit none

  real &
     fc,fd
  integer &
     iphase,k,ndem
!
!  array arguments
  real &
     ampl(ndem),phase(iphase,2)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     pi,ymn,ymx
  logical &
     error
!
!  local arrays
  integer &
     isym(1)
!
!  external subroutines
  external getpi,versp,vplmt,vpmn
!
!  common blocks
  common /errchk/ierr

  call versp(.true.)

  call getpi(pi)

  write ( *, 1000) fd, fc, k

  write ( *, 1001)
  call vplmt(ampl, ampl, ndem, 1, ndem, 0.0e0, 0.0e0, &
    ymn, ymx, error, nmsub, .false., 1)

  if (error) then
    ierr = 1
    return
  end if

  call vpmn ( ampl, ampl, ndem, 1, ndem, 1, 0, isym, 1, 0, &
     ymn, ymx, 1.0e0, 1.0e0, .false., 0, 1, 0)

  write ( *, 1002)
  call versp(.true.)
  write ( *, 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)

  return

 1000 format (/' time series demodulation'// &
     ' demodulation frequency is', f10.8/ &
     ' cutoff frequency is      ', f10.8/ &
     ' the number of terms in the filter is ', i5///)
 1001 format (' plot of amplitude of smoothed demodulated series')
 1002 format ('1')
 1003 format (' plot of phase of smoothed demodulated series')
end
subroutine dfault ( iv, v )

!***********************************************************************
!
!! DFAULT supplies default values to IV and V.
!
!  Discussion:
!
!    Only entries in the first 25 positions of IV and the first 45
!    positions of V are reset.
!
!  Modified:
!
!    05 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Output, integer IV(25), contains default values for specific entries.
!
!    Output, real V(45), contains default values for specific values.
!
  implicit none

  integer :: afctol = 31
  integer :: cosmin = 43
  integer :: covprt = 14
  integer :: covreq = 15
  integer :: d0init = 37
  integer :: decfac = 22
  integer :: delta0 = 44
  integer :: dfac = 41
  integer :: dinit = 38
  integer :: dltfdc = 40
  integer :: dltfdj = 36
  integer :: dtype = 16
  integer :: inits = 25
  integer :: epslon = 19
  integer :: fuzz = 45
  integer :: incfac = 23
  integer iv(25)
  integer :: jtinit = 39
  integer :: lmax0 = 35
  real machep
  real mepcrt
  integer :: mxfcal = 17
  integer :: mxiter = 18
  integer :: outlev = 19
  integer :: parprt = 20
  integer :: phmnfc = 20
  integer :: phmxfc = 21
  integer :: prunit = 21
  integer :: rdfcmn = 24
  integer :: rdfcmx = 25
  integer :: rfctol = 32
  integer :: rlimit = 42
  integer :: solprt = 22
  real sqteps
  integer :: statpr = 23
  integer :: tuner1 = 26
  integer :: tuner2 = 27
  integer :: tuner3 = 28
  integer :: tuner4 = 29
  integer :: tuner5 = 30
  real v(45)
  integer :: x0prt = 24
  integer :: xctol = 33
  integer :: xftol = 34

  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) = 6
  iv(solprt) = 1
  iv(statpr) = 1
  iv(x0prt) = 1

  machep = epsilon ( machep )
  v(afctol) = 1.0e-20
  if ( 1.0e-10 < machep ) then
    v(afctol) = machep**2
  end if
  v(cosmin) = max ( 1.0e-06, 1.0e+02 * machep )
  v(decfac) = 0.5e+00
  sqteps = sqrt ( epsilon ( sqteps ) )
  v(delta0) = sqteps
  v(dfac) = 0.6e+00
  v(dinit) = 0.0e+00
  mepcrt = machep ** ( 1.0E+00 / 3.0E+00 )
  v(dltfdc) = mepcrt
  v(dltfdj) = sqteps
  v(d0init) = 1.0e+00
  v(epslon) = 0.1e+00
  v(fuzz) = 1.5e+00
  v(incfac) = 2.0e+00
  v(jtinit) = 1.0e-06
  v(lmax0) = 100.e+00
  v(phmnfc) = -0.1e+00
  v(phmxfc) = 0.1e+00
  v(rdfcmn) = 0.1e+00
  v(rdfcmx) = 4.e+00
  v(rfctol) = max ( 1.0E-10, mepcrt**2 )
  v(rlimit) = sqrt ( 0.999E+00 * huge ( v(rlimit) ) )
  v(tuner1) = 0.1e+00
  v(tuner2) = 1.0e-04
  v(tuner3) = 0.75e+00
  v(tuner4) = 0.5e+00
  v(tuner5) = 0.75e+00
  v(xctol) = sqteps
  v(xftol) = 1.0e+02 * machep

  return
end
subroutine dfbw ( n, lag, w, lw, df, bw )

!*****************************************************************************80
!
!! DFBW computes degrees of freedom and bandwidth for a given lag window.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real bw
!        the bandwidth.
!     real df
!        the effective degrees of freedom.
!     integer k
!        an index variable
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lw
!        the length of the vector w.
!     integer n
!        the number of observations in the series.
!     real w(lw)
!        the vector of lag windows.
!
  implicit none

  real &
     bw,df
  integer &
     lag,lw,n
!
!  array arguments
  real &
     w(lw)
!
!
  integer &
     k

  bw = 0.0e0
  do k = 1, lag
     bw = bw + w(k+1) * w(k+1) * real ( n - k )
  end do

  bw = 1.0e0 / (w(1)*w(1) + 2.0e0*bw / real ( n ) )
  df = 2.0e0 * bw * real ( n )

  return
end
subroutine dfbwm ( n, lag, w, lw, nlppa1, nlppa2, lnlppa, df, bw )

!*****************************************************************************80
!
!! DFBWM computes DOF and BW for a given lag window with missing data.
!
!  Discussion:
!
!    This routine computes and stores the associated degrees of
!    freedom and bandwidth for a given lag window when missing data are
!    involved.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real bw
!        the bandwidth.
!     real df
!        the effective degrees of freedom.
!     integer k
!        an index variable
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lw
!        the length of the vector w.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer n
!        the number of observations in the series.
!     integer nlppa1(lnlppa), nlppa2(lnlppa)
!        the number of lagged product pairs used for each acvf
!        estimate.
!     real w(lw)
!        the vector of lag windows.
!
  implicit none

  real &
     bw,df
  integer &
     lag,lnlppa,lw,n
!
!  array arguments
  real &
     w(lw)
  integer &
     nlppa1(lnlppa),nlppa2(lnlppa)
!
!
  integer &
     k

  bw = (w(1)* real ( n ) )**2 / real  ( nlppa1(1) )
  do k = 1, lag
     bw = bw + (w(k+1) * real ( n - k ) )**2 * &
        ( 1.0e0 / real ( nlppa1(k+1) ) + 1.0e0 / real( nlppa2(k+1) ) )
  end do

  bw = real ( n ) / bw
  df = 2.0e0 * bw * real ( n )

  return
end
subroutine difc ( y, n, nfac, nd, iod, iar, phi, lphi, yf, nyf, ldstak )

!*****************************************************************************80
!
!! DIFC expands a difference filter and performs difference filtering.
!
!  Discussion:
!
!    This routine expands the difference filter specified by nfac,
!    iod and nd into phi and performs the difference filtering
!    operation defined by phi, returning the filtered series in yf.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03, err04
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer iar
!        the number of filter coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer iod(nfac)
!        the order of each of the difference factors.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 llds(8), llphi(8), ln(8)
!        the arrays containing the names of various variables
!     integer lphi
!        the length of the array phi.
!     integer n
!        the number of observations in the series y.
!     integer nall0
!        the number of outstanding work area allocations.
!     integer nd(nfac)
!        the array containing the number of times the difference
!        factors are to be applied.
!     integer nfac
!        the number of difference factors.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real phi(lphi)
!        the vector containing the filter coefficients.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer work
!        the starting location for the work vector necessary to
!        expand the difference filter.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  implicit none

  integer &
     iar,ldstak,lphi,n,nfac,nyf
!
!  array arguments
  real &
     phi(*),y(*),yf(*)
  integer &
     iod(*),nd(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer ldsmin,nall0,work
  logical &
     err01,err02,err03,err04,head
!
!  local arrays
  real &
     rstak(12)
  character &
     llds(8)*1,llphi(8)*1,ln(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external dcoef,eisge,erdf,fltar,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  err01 = .false.
  err02 = .false.
  err03 = .false.
  err04 = .false.
!
!  call error checking routines
!
  call eisge(nmsub,ln,n,3,1,head,err01,ln)

  iar = 0

  if (nfac >= 1) then

    iar = dot_product ( nd(1:nfac), iod(1:nfac) )

     call erdf(nmsub,nfac,nd,iod,n,head,err02)

     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

  if (err01 .or. err02 .or. err03 .or. err04) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  nyf = n
  yf(1:nyf) = y(1:nyf)

  if (nfac <= 0) return

  call stkset (ldstak, 4)
  nall0 = stkst(1)

  phi(1:lphi) = 0.0e0

  work = stkget(2*iar, 3)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call dcoef (nfac,nd,iod,iar,phi,lphi,rstak(work))

  call stkclr(nall0)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call fltar (yf,nyf,iar,phi,yf,nyf)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call difc (y, n,'/ &
     '      +           nfac, nd, iod, iar, phi, lphi,'/ &
     '      +           yf, nyf, ldstak)')
end
subroutine dif ( y, n, yf, nyf )

!*****************************************************************************80
!
!! DIF performs a first difference filtering operation.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical err01
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer iar
!        the number of filter coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     character*1 ln(8)
!        the arrays containing the names of the variables n.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real phi(1)
!        the vector containing the filter coefficients.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  implicit none

  integer &
     n,nyf
!
!  array arguments
  real &
     y(*),yf(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     iar
  logical &
     err01,head
!
!  local arrays
  real &
     phi(1)
  character &
     ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,fltar
!
!  common blocks
  common /errchk/ierr
!
!  set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  if ( err01 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  iar = 1
  phi(1) = 1.0e0

  call fltar (y, n, iar, phi, yf, nyf)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call dif (y, n, yf, nyf)')
end
subroutine difmc ( y, ymiss, n, nfac, nd, iod, iar, phi, lphi, yf, &
     yfmiss, nyf, ldstak )

!*****************************************************************************80
!
!! DIFMC expands a difference filter and performs the difference filter.
!
!  Discussion:
!
!    This routine expands the difference filter specified by NFAC,
!    IOD and ND into PHI and performs the difference filtering
!    operation defined by PHI on a series containing missing data,
!    returning the filtered series in YF.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03, err04
!        values indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer iar
!        the number of filter coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer iod(nfac)
!        the order of each of the difference factors.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 llds(8), llphi(8), ln(8)
!        the arrays containing the names of the variables ldstak, n
!        and lphi, respectively.
!     integer lphi
!        the length of the vector phi.
!     integer n
!        the number of observations in the series y.
!     integer nall0
!        the number of outstanding stack allocations.
!     integer nd(nfac)
!        the array containing the number of times the difference
!        factors are to be applied.
!     integer nfac
!        the number of difference factors.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real phi(lphi)
!        the vector containing the filter coefficients.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer work
!        the starting location for the work vector necessary to
!        expand the difference filter.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!     real yfmiss
!        the missing value code used in the filtered series to
!        indicate the value could not be computed due to missing data.
!     real ymiss
!        the missing value code used in the input series to indicate
!        an observation is missing.
!
  implicit none

  real &
     yfmiss,ymiss
  integer &
     iar,ldstak,lphi,n,nfac,nyf
!
!  array arguments
  real &
     phi(*),y(*),yf(*)
  integer &
     iod(*),nd(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer ldsmin,nall0,work
  logical &
     err01,err02,err03,err04,head
!
!  local arrays
  real &
     rstak(12)
  character &
     llds(8)*1,llphi(8)*1,ln(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external dcoef,eisge,erdf,fltarm,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  err01 = .false.
  err02 = .false.
  err03 = .false.
  err04 = .false.
!
!  call error checking routines
!
  call eisge(nmsub,ln,n,3,1,head,err01,ln)

  iar = 0

  if (nfac >= 1) then

    iar = dot_product ( nd(1:nfac), iod(1:nfac) )

     call erdf(nmsub,nfac,nd,iod,n,head,err02)

     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

  if (err01 .or. err02 .or. err03 .or. err04) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  nyf = n
  yf(1:nyf) = y(1:nyf)

  yfmiss = ymiss

  if (nfac <= 0) return

  call stkset (ldstak, 4)
  nall0 = stkst(1)
  phi(1:lphi) = 0.0e0

  work = stkget(2*iar,3)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call dcoef (nfac,nd,iod,iar,phi,lphi,rstak(work))

  call stkclr(nall0)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call fltarm (yf,ymiss,nyf,iar,phi,yf,yfmiss,nyf)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call difmc (y, ymiss, n,'/ &
     '      +            nfac, nd, iod, iar, phi, lphi,'/ &
     '      +            yf, yfmiss, nyf, ldstak)')
end
subroutine difm ( y, ymiss, n, yf, yfmiss, nyf )

!*****************************************************************************80
!
!! DIFM performs a first difference filter for a series with missing data.
!
!  Discussion:
!
!    This routine performs a first difference filtering operation,
!    returning the filtered series in yf, for an input series
!    containing missing values.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical err01
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer iar
!        the number of filter coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     character*1 ln(8)
!        the arrays containing the names of the variables n.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real phi(1)
!        the vector containing the filter coefficients.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!     real yfmiss
!        the missing value code used in the filtered series to
!        indicate the value could not be computed due to missing data.
!     real ymiss
!        the missing value code used in the input series to indicate
!        an observation is missing.
!
  implicit none

  real &
     yfmiss,ymiss
  integer &
     n,nyf
!
!  array arguments
  real &
     y(*),yf(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer iar
  logical &
     err01,head
!
!  local arrays
  real &
     phi(1)
  character &
     ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,fltarm
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  if ( err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  iar = 1
  phi(1) = 1.0e0

  call fltarm (y, ymiss, n, iar, phi, yf, yfmiss, nyf)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call difm (y, ymiss, n, yf, yfmiss, nyf)')
end
subroutine difser ( y, n, ndf, nd, iod, ydiff, ndiff )

!*****************************************************************************80
!
!! DIFSER performs a differencing operation on a series.
!
!  Discussion:
!
!    This routine performs the differencing operation
!    defined by nd, iod and ndf on the series y, resulting in
!    the series ydiff.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iod(ndf)
!        the vector containing the orders of each difference factor.
!     integer n
!        the number of observations.
!     integer nd(ndf)
!        the vector containing the number of times each differencing
!        factor is applied.
!     integer ndf
!        the number of difference factors.
!     integer ndiff
!        the number of observations remaining in the differenced series.
!     integer ntimes
!        the number of times a given difference factor is to be applied.
!     real y(n), ydiff(n)
!        the vector containing the series observations and the vector
!        in which the differenced series is returned.
!
  implicit none

  integer &
     n,ndf,ndiff
!
!  array arguments
  real &
     y(*),ydiff(*)
  integer &
     iod(*),nd(*)
!
!
  integer &
     i,j,k,l,ntimes

  ydiff(1:n) = y(1:n)

  ndiff = n

  do i = 1, ndf
     ntimes = nd(i)
     do l = 1, ntimes
        ndiff = ndiff - iod(i)
        do j = 1, ndiff
           k = j + iod(i)
           ydiff(j) = ydiff(k) - ydiff(j)
        end do
     end do

  end do

  return
end
subroutine dotc ( y, ymean, ny, x, xmean, nx, dotxy, ndotxy )

!*****************************************************************************80
!
!! DOTC computes the dot product of two series, centered about their means.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real dotxy
!        the dot product of the series (y(i) - ymean) and
!        (x(i) - xmean).
!     integer i
!        an index variable.
!     integer m
!        the smaller of the number of observations in x and y
!     integer ndotxy
!        the number of observations used to compute dotxy
!     integer nx, ny
!        the number of observations in series x and y, respectively.
!     real x(nx)
!        the vector containing the second series
!     real xmean
!        the mean of the second series.
!     real y(ny)
!        the vector containing the first series
!     real ymean
!        the mean of the first series.
!
  implicit none

  real &
     dotxy,xmean,ymean
  integer &
     ndotxy,nx,ny
!
!  array arguments
  real &
     x(nx),y(ny)
!
!
  integer &
     i,m

  ndotxy = 0
  dotxy = 0.0e0
  m = min(ny, nx)
  do i = 1, m
     dotxy = dotxy + (y(i) - ymean) * (x(i) - xmean)
     ndotxy = ndotxy + 1
  end do

  return
end
subroutine dotcm ( y, ymean, ymiss, ny, x, xmean, xmiss, nx, dotxy, ndotxy )

!*****************************************************************************80
!
!! DOTCM computes the dot product of series with missing data.
!
!  Discussion:
!
!    The series are centered about their respective means.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real dotxy
!        the dot product of the series (y(i) - ymean) and
!        (x(i) - xmean).
!     integer i
!        an index variable.
!     integer m
!        the smaller of the number of observations in x and y
!     integer ndotxy
!        the number of observations used to compute dotxy
!     integer nx, ny
!        the number of observations in series x and y, respectively.
!     real x(nx)
!        the vector containing the second series
!     real xmean
!        the mean of the second series.
!     real xmiss
!        the user supplied code which is used to determine whether or
!        not an observation in the series is missing.  if x(i) = xmiss,
!        the value is assumed missing, otherwise it is not.
!     real y(ny)
!        the vector containing the first series
!     real ymean
!        the mean of the first series.
!     real ymiss
!        the user supplied code which is used to determine whether or
!        not an observation in the series is missing.  if y(i) = ymiss,
!        the value is assumed missing, otherwise it is not.
!
  implicit none

  real &
     dotxy,xmean,xmiss,ymean,ymiss
  integer &
     ndotxy,nx,ny
!
!  array arguments
  real &
     x(nx),y(ny)
!
!
  integer &
     i,m
!
!  external functions
  logical &
     mvchk
  external mvchk

  ndotxy = 0
  dotxy = 0.0e0
  m = min(ny, nx)
  do i = 1, m
    if ( .not. ( mvchk(y(i), ymiss) .or. mvchk(x(i), xmiss) ) ) then
      dotxy = dotxy + (y(i) - ymean) * (x(i) - xmean)
      ndotxy = ndotxy + 1
    end if
  end do

  return
end
function dotprd ( p, x, y )

!*****************************************************************************80
!
!! DOTPRD returns the inner product of two vectors.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer P, the number of entries in the vectors.
!
!    Input, real X(P), Y(P), the vectors.
!
!    Output, real DOTPRD, the dot product of X and Y.
!
  implicit none

  integer p

  real dotprd
  integer i
  real, save :: sqteta = 0.0E+00
  real t
  real x(p)
  real y(p)

  dotprd = 0.0E+00

  if ( p <= 0 ) then
    return
  end if

  if ( sqteta == 0.0E+00 ) then
    sqteta = sqrt ( 1.001E+00 * tiny ( sqteta ) )
  end if

  do i = 1, p

    t = max ( abs ( x(i) ), abs ( y(i) ) )

    if ( t < sqteta ) then

    else if ( 1.0E+00 < t ) then

      dotprd = dotprd + x(i) * y(i)

    else

      t = ( x(i) / sqteta ) * y(i)

      if ( sqteta <= abs ( t ) ) then
        dotprd = dotprd + x(i) * y(i)
      end if

    end if

  end do

  return
end
subroutine drv1a ( coef, ncoef, xm, n, m, ixm, d )

!*****************************************************************************80
!
!! DRV1A derivative function for NLS family exerciser subroutine MDL1.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real coef(ncoef)
!        model coefficients
!     real d(n,ncoef)
!        the first derivative with respect to the ith coefficient
!     integer i
!        row marker
!     integer ixm
!        actual first dimension of xm
!     integer m
!        the number of independent variablesc
!     integer n
!        the number of observations
!     integer ncoef
!        the number of coefficients
!     real xm(ixm,m)
!        independent variables
!
  integer &
     ixm,m,n,ncoef
!
!  array arguments
  real &
     coef(ncoef),d(n,ncoef),xm(ixm,m)

  d(1:n,1) = xm(1:n,1)**coef(2)
  d(1:n,2) = coef(1) * (xm(1:n,1)**coef(2)) * log(xm(1:n,1))

  return
end
subroutine drv1b ( par, npar, xm, n, m, ixm, d )

!*****************************************************************************80
!
!! DRV1B is an INCORRECT derivative function for the NLS exerciser MDL1.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real d(n,npar)
!        the first derivative with respect to the ith coefficient
!     integer i
!        row marker
!     integer ixm
!        actual first dimension of xm
!     integer m
!        the number of independent variablesc
!     integer n
!        the number of observations
!     integer npar
!        the number of coefficients
!     real par(npar)
!        model coefficients
!     real xm(ixm,m)
!        independent variables
!
  implicit none

  integer &
     ixm,m,n,npar
!
!  array arguments
  real &
     d(n,npar),par(npar),xm(ixm,m)

  d(1:n,1) = xm(1:n,1) * par(2)
  d(1:n,2) = par(1) * ( xm(1:n,1)**par(2) ) * log ( xm(1:n,1) )

  return
end
subroutine drv2 ( par, npar, xm, n, m, ixm, d )

!*****************************************************************************80
!
!! DRV2 is a derivative function for the NLS exerciser routine MD12.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real par(npar)
!        model parameters
!     real d(n,npar)
!        the first derivative with respect to the ith parameter
!     integer i
!        row marker
!     integer ixm
!        actual first dimension of xm
!     integer m
!        the number of independent variablesc
!     integer n
!        the number of observations
!     integer npar
!        the number of parameters
!     real xm(ixm,m)
!        model independent variable
!
  implicit none

  integer &
     ixm,m,n,npar

  real &
     d(n,npar),par(npar),xm(ixm,m)

  d(1:n,1) = xm(1:n,1)
  d(1:n,2) = xm(1:n,2)
  d(1:n,3) = xm(1:n,3)**3

  return
end
subroutine drv3 ( par, npar, xm, n, m, ixm, d )

!*****************************************************************************80
!
!! DRV3 is the derivative function for NLS family exerciser subroutine MDL3.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real par(npar)
!        model parameters
!     real d(n,npar)
!        the first derivative with respect to the ith parameter
!     integer i
!        row marker
!     integer ixm
!        actual first dimension of xm
!     integer m
!        the number of independent variablesc
!     integer n
!        the number of observations
!     integer npar
!        the number of parameters
!     real xm(ixm,m)
!        independent variable
!
  implicit none

  integer &
     ixm,m,n,npar
!
!  array arguments
  real &
     d(n,npar),par(npar),xm(ixm,m)

  d(1:n,1:npar) = xm(1:n,1:npar)

  return
end
subroutine drv4a ( coef, ncoef, xm, n, m, ixm, d )

!*****************************************************************************80
!
!! DRV4A is a (correct) derivative for testing derivative checking routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real coef(ncoef)
!        the array in which the current estimates of the unknown
!        coefficients are stored.
!     real d(n,ncoef)
!        the matrix of first partial derivatives (jacobian).
!     integer i
!        an index variable.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations of data.
!     integer ncoef
!        the number of unknown coefficients in the model.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  integer &
     ixm,m,n,ncoef
!
!  array arguments
  real &
     coef(ncoef),d(n,ncoef),xm(ixm,m)

  integer &
     i

  do 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))
  end do

  return
end
subroutine drv4b ( coef, ncoef, xm, n, m, ixm, d )

!*****************************************************************************80
!
!! DRV4B is an (incorrect) derivative for testing derivative checking routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real coef(ncoef)
!        the array in which the current estimates of the unknown
!        coefficients are stored.
!     real d(n,ncoef)
!        the matrix of first partial derivatives (jacobian).
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations of data.
!     integer ncoef
!        the number of unknown coefficients in the model.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  integer &
     ixm,m,n,ncoef
!
!  array arguments
  real &
     coef(ncoef),d(n,ncoef),xm(ixm,m)
!
!
  integer &
     i

  do 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))
  end do

  return
end
subroutine drv ( par, npar, xm, n, m, ixm, d )

!*****************************************************************************80
!
!! DRV is a dummy derivative function for the NLS family.
!
!  Discussion:
!
!    To solve an actual problem, the user would write a routine with
!    the same calling sequence as this dummy routine. 
!
!    The user's routine would return the information defining the problem
!    being studied.
!
!  Modified:
!
!    19 May 2007
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real d(n,npar)
!        the first derivative with respect to the ith parameter
!     integer ixm
!        actual first dimension of xm
!     integer m
!        the number of independent variablesc
!     integer n
!        the number of observations
!     integer npar
!        the number of parameters
!     real par(npar)
!        model parameters
!     real xm(ixm,m)
!        model independent variable
!
  implicit none

  integer ixm
  integer m
  integer n
  integer npar

  real d(n,npar)
  real par(npar)
  real xm(ixm,m)
!
!  The following assignments are just to keep the compiler from complaining
!  about unused variables.
!
  d(1:n,1:npar) = 0.0
  par(1:npar) = 0.0
  xm(1:ixm,1:m) = 0.0

  return
end
subroutine dupdat ( d, iv, j, n, nn, p, v )

!*****************************************************************************80
!
!! DUPDAT updates the scale vector for NL2ITR.
!
!  Modified:
!
!    05 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input/output, real D(P), the scale vector.
!
!    Input, integer IV(*), the NL2SOL integer array.
!
!    Input, real J(NN,P), the N by P Jacobian matrix.
!
!    Input, integer N, the number of functions.
!
!    Input, integer NN, the leading dimension of J.
!
!    Input, integer P, the number of variables.
!
!    Input, real V(*), the NL2SOL real array.
!
  implicit none

  integer nn
  integer p

  real d(p)
  integer d0
  integer :: dfac = 41
  integer :: dtype = 16
  integer i
  integer iv(*)
  real j(nn,p)
  integer :: jtol0 = 86
  integer jtoli
  integer n
  integer :: niter = 31
  integer :: s = 53
  integer s1
  real sii
  real t
  real v(*)
  real v2norm
  real vdfac

  i = iv(dtype)

  if ( i /= 1 ) then

    if ( 0 < iv(niter) ) then
      return
    end if

  end if

  vdfac = v(dfac)
  d0 = jtol0 + p
  s1 = iv(s) - 1

  do i = 1, p

    s1 = s1 + i
    sii = v(s1)
    t = v2norm ( n, j(1,i) )

    if ( 0.0E+00 < sii ) then
      t = sqrt ( t * t + sii )
    end if

    jtoli = jtol0 + i
    d0 = d0 + 1

    if ( t < v(jtoli) ) then
      t = max ( v(d0), v(jtoli) )
    end if

    d(i) = max ( vdfac * d(i), t )

  end do

  return
end
subroutine e9rint ( messg, nw, nerr, save )

!*****************************************************************************80
!
!! E9RINT stores the current error message or prints the old one.
!
!  Discussion:
!
!    This routine stores the current error message or prints the old one,
!    if any, depending on whether or not save = .true. .
!
!     character*4 messg(nw)
!     logical save
!
!  messgp stores at least the first 72 characters of the previous
!  message. its length is machine dependent and must be at least
!
!       1 + 71/(the number of characters stored per integer word).
!
!     character*4 messgp(36),fmt(14),ccplus
!
!
  implicit none
!
!  scalar arguments
  integer nerr,nw
  logical save
!
!  array arguments
  character messg(nw)*4
!
!
  integer i,iwunit,nerrp,nwp
  character ccplus*4
!
!  local arrays
  character fmt(14)*4,messgp(36)*4
!
!  external functions
  integer i1mach,i8save
  external i1mach,i8save
!
!  external subroutines
  external s88fmt
!
!  start with no previous message.
!
  data messgp(1)/'1'/, nwp/0/, nerrp/0/
!
!  set up the format for printing the error message.
!  the format is simply (a1,14x,72axx) where xx=i1mach(6) is the
!  number of characters stored per integer word.
!
  data ccplus  / '+' /

  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) / ')' /
!
!  Save the message.
!
  if ( save ) then

    nwp=nw
    nerrp=nerr
    messgp(1:nw)=messg(1:nw)
!
!  Print the message.
!
  else if ( i8save ( 1, 0, .false. ) /= 0 ) then

    iwunit=i1mach(4)
    write ( iwunit, '(a,i4,a)' ) '  Error ', nerrp, ' in '
    call s88fmt ( 2, i1mach(6), fmt(12) )
    write(iwunit,fmt) ccplus, (messgp(i),i=1,nwp)

  end if

  return
end
subroutine ecvf ( nmsub )

!*****************************************************************************80
!
!! ECVF prints an error message if missing data affects the covariance lags.
!
!  Discussion:
!
!    This routine prints an error message when the lag value of
!    the last covariance computed before one was not computed
!    due to missing data does not exceed zero.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!
  implicit none

  character &
     nmsub(6)*1

  logical &
     head
!
!  external subroutines
  external ehdr

  head = .true.

  call ehdr(nmsub, head)

  write ( *, 1010)
  return

 1010 format (/ &
     ' the covariances at lags zero and/or one could', &
     ' not be computed'/ &
     ' because of missing data.  no further analysis is', &
     ' possible.')

end
subroutine ehdr ( nmsub, head )

!*****************************************************************************80
!
!! EHDR prints the heading for the error checking routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!
  implicit none

  logical &
     head
!
!  array arguments
  character &
     nmsub(6)*1

  integer i
!
!  external subroutines
  external versp
!
  if (.not.head) return

  call versp(.false.)
  write ( *,1010)
  write ( *, 1000) (nmsub(i), i=1,6)
  head = .false.

  return

 1000 format (/' error checking for subroutine ', 6a1/ 1x, 37('-'))
 1010 format ('+', 18('*')/' * error messages *'/1x, 18('*'))

end
subroutine eiage ( nmsub, nmvar, ym, n, m, iym, ymmn, nvmx, &
     head, msgtyp, nv, error, nmmin )

!*****************************************************************************80
!
!! EIAGE ensures that "not too many" vectors are below a given lower bound.
!
!  Discussion:
!
!    This routine checks to ensure that no values, or only a maximum
!    of nvmx, are not greater than a specified lower bound ymmn,
!    with name nmmin.   the checking option is specified
!    with msgtyp.  if an error is found, the error is printed and
!    an error flag and the number of violatins are returned.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer iym
!        the first dimension of the array ym.
!     integer j
!        an indexing variable.
!     integer m
!        the number of columns of data in ym.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 3) the message printed will use nmmin
!        otherwise it will use ymmn.
!        if (msgtyp = 1 or 3) no violations are allowed.
!        if (msgtyp = 2 or 4) the number of violations must
!                             be less than   nvmx   .
!     integer n
!        the number of observations.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     character*1 nmvar(8)
!        the characters of the parameters name.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!     integer ym(iym,m)
!        the array being tested.
!     integer ymmn
!        the minimum acceptable value.
!
  implicit none

  integer &
     iym,m,msgtyp,n,nv,nvmx,ymmn
  logical &
     error,head
!
!  array arguments
  integer &
     ym(*)
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1

  integer &
     i,j
!
!  external subroutines
  external eiagep

  error = .false.

  if ((n <= 0) .or. (m <= 0)) return
!
!  check for violations
!
  nv = 0
  do i = 1, n
     do j = 1, m
        if (ym(i+(j-1)*iym) < ymmn) nv = nv + 1
     end do
  end do

  if (nv <= nvmx) then
    return
  end if
!
!  violations found
!
  error = .true.

  call eiagep (nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, &
     nmmin)

  return
end
subroutine eiagep ( nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, nmmin )

!*****************************************************************************80
!
!! EIAGEP prints the error messages for ERAGT and ERAGTM.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 3) the message printed will use nmmin
!        otherwise it will use ymmn.
!        if (msgtyp = 1 or 3) no violations are allowed.
!        if (msgtyp = 2 or 4) the number of violations must
!                             be less than   nvmx   .
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     character*1 nmvar(8)
!        the characters of the parameters name.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!     integer ymmn
!        the minimum acceptable value.
!
  implicit none

  integer &
     msgtyp,nv,nvmx,ymmn
  logical &
     head
!
!  array arguments
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i
!
!  external subroutines
  external ehdr

  call ehdr(nmsub, head)

  if (msgtyp <= 2) then
     write ( *, 1000) (nmvar(i),i=1,6), ymmn, nv
  else
     write ( *, 1005) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv
  end if

  if ( msgtyp == 1 ) then
    write ( *, 1010) (nmvar(i),i=1,6), ymmn
  else if ( msgtyp == 2 ) then
    write ( *, 1020) (nmvar(i),i=1,6), ymmn, nvmx
  else if ( msgtyp == 3 ) then
    write ( *, 1030) (nmvar(i),i=1,6), (nmmin(i),i=1,8)
  else if ( msgtyp == 4 ) then
    write ( *, 1040) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nvmx
  end if

  return

 1000 format (/ &
     ' the number of values in array ', 6a1, &
     ' less than ', i5, ' is ', i6, '.')
 1005 format (/ &
     ' the number of values in array ', 6a1, &
     ' less than ', 8a1, ' is ', i6, '.')
 1010 format( &
     ' the values in the array ', 6a1, &
     ' must all be greater than or equal to ', i5, '.')
 1020 format( &
     ' the number of values in the array ', 6a1, &
     ' less than ', 8a1/ &
     ' must be less than ', i5, '.')
 1030 format( &
     ' the values in the array ', 6a1, &
     ' must all be greater than or equal to ', i5, '.')
 1040 format( &
     ' the number of values in the array ', 6a1, &
     ' less than ', 8a1/ &
     ' must be less than ', i5, '.')
end
subroutine eiseq ( nmsub, nmvar1, nval, neq, msgtyp, head, error, nmvar2 )

!*****************************************************************************80
!
!! EISEQ prints an error message if NVAL is not equal to NEQ.
!
!  Discussion:
!
!    This is a surprisingly cumbersome routine for such a simple task!
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is true and
!        msgtyp = 1 the input value was not equal to the number of param
!                   specified by mspec (arima estimation and forecasting
!     integer neq
!        the acceptable value for the argument being tested.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar1(8)
!        the characters of the name of the argument being checked.
!     character*1 nmvar2(8)
!        the characters of the name of the argument being checked
!        against.
!     integer nval
!        the input value of the argument being checked.
!
  implicit none

  integer &
     msgtyp,neq,nval
  logical &
     error,head
!
!  array arguments
  character &
     nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1

  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (nval == neq) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar1(i), i=1,6), nval
!
!  print message for arima routines
!
  write ( *, 1010) (nmvar1(i), i=1,6), neq
  return

 1000 format (/' the input value of ', 6a1, ' is ', i5, '.')
 1010 format( &
     ' 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.')

end
subroutine eisge( nmsub, nmvar1, nval, nmin, msgtyp, head, error, nmvar2 )

!*****************************************************************************80
!
!! EISGE prints a warning if NVAL is less than NMIN.
!
!  Discussion:
!
!    This routine checks whether the value   nval   is greater than
!    or equal to   nmin   and prints a diagnostic if it is not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is true and
!        msgtyp = 1 the input value was too small based
!                   on limits imposed by starpac
!        msgtyp = 2 the input value was too small based on other input
!                   arguments.
!        msgtyp = 3 the input value was too small based on other input
!                   arguments, where the value indicates the first
!                   dimension of a dimensioned array
!                   n.b.  it is assumed that the dimension name is the
!                         array name preceded by the letter i.  if the
!                         array name is 6 letters, the dimension name
!                         should omit the last letter.  the dimension
!                         name will be printed using (nmvar(i),i=1,6),
!                         and the array name using (nmvar(i),i=2,7).
!        msgtyp = 4 the input value was too small based on other input
!                   arguments, where the value indicates the second
!                   dimension of a dimensioned array
!                   n.b.  it is assumed that the dimension name is the
!                         array name preceded by the letter j.  if the
!                         array name is 6 letters, the dimension name
!                         should omit the last letter.  the dimension
!                         name will be printed using (nmvar(i),i=1,6),
!                         and the array name using (nmvar(i),i=2,7).
!        msgtyp = 5 the argument being checked is ldstak.
!                   no longer used.
!        msgtyp = 6 the argument indicates the first dimension of
!                   an array being checked against the number of
!                   unfixed parameters.
!        msgtyp = 7 the input value was too small based on other input
!                   arguments, where the value indicates the
!                   dimension of a vector.
!                   n.b.  it is assumed that the dimension name is the
!                         array name preceded by the letter l.  if the
!                         array name is 6 letters, the dimension name
!                         should omit the last letter.  the dimension
!                         name will be printed using (nmvar(i),i=1,6),
!                         and the array name using (nmvar(i),i=2,7).
!        msgtyp = 8 the input value was too small based on other input
!                   arguments, where the value indicates the
!                   dimension of the vectors acov and nlppa.
!        msgtyp = 9 the input value was too small based on limits
!                   imposed by starpac, where the value indicates the
!                   dimension of a vector.
!                   n.b.  it is assumed that the dimension name is the
!                         array name preceded by the letter l.  if the
!                         array name is 6 letters, the dimension name
!                         should omit the last letter.  the dimension
!                         name will be printed using (nmvar(i),i=1,6),
!                         and the array name using (nmvar(i),i=2,7).
!     integer nmin
!        the minimum acceptable value for the argument being tested.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar1(8)
!        the characters of the name of the argument being checked.
!     character*1 nmvar2(8)
!        the characters of the name of the argument being checked
!        against.
!     integer nval
!        the input value of the argument being checked.
!
  implicit none

  integer &
     msgtyp,nmin,nval
  logical &
     error,head
!
!  array arguments
  character &
     nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1

  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (nval  >=  nmin) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar1(i), i=1,6), nval

  if ( msgtyp == 1 ) then
    write ( *, 1010) (nmvar1(i), i=1,6), nmin
  else if ( msgtyp == 2 ) then
    write ( *, 1020) (nmvar1(i), i=1,6), (nmvar2(i), i=1,8)
  else if ( msgtyp == 3 ) then
    write ( *, 1030) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), &
     (nmvar2(i), i=1,8)
  else if ( msgtyp == 4 ) then
    write ( *, 1040) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), &
     (nmvar2(i), i=1,8)
  else if ( msgtyp == 5 ) then
    write ( *, 1050) nmin
  else if ( msgtyp == 6 ) then
    write ( *, 1060) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6)
  else if ( msgtyp == 7 ) then
    write ( *, 1070) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), &
     (nmvar2(i), i=1,8)
  else if ( msgtyp == 8 ) then
    write ( *, 1080) (nmvar1(i), i=1,6), (nmvar2(i), i=1,8)
  else if ( msgtyp == 9 ) then
    write ( *, 1090) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), nmin
  end if

  return

 1000 format (/' the input value of ', 6a1, ' is ', i5, '.')
 1010 format( &
     ' the value of the argument ', 6a1, &
     ' must be greater than or equal to ', i5, '.')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must be greater than or equal to ', 8a1, '.')
 1030 format( &
    ' the first dimension of ', 6a1, &
     ', as indicated by the argument'/ &
      1x, 6a1, ', must be greater than or equal to ', 8a1, '.')
 1040 format( &
     ' the second dimension of ', 6a1, &
     ', as indicated by the argument'/ &
      1x, 6a1, ', must be greater than or equal to ', 8a1, '.')
 1050 format( &
     ' the dimension of the double precision vector dstak, as', &
     ' indicated by'/ &
     ' the argument ldstak, must be greater than or equal to', &
     i5, '.')
 1060 format( &
     ' the first dimension of ', 6a1, &
     ', as indicated by the argument'/ &
      1x, 6a1, ', must be greater than or equal to', &
     ' the number of unfixed parameters.')
 1070 format( &
     ' the length of ', 6a1, &
     ', as indicated by the argument'/ &
      1x, 6a1, ', must be greater than or equal to ', 8a1, '.')
 1080 format( &
     ' the length of acov and nlppa', &
     ', as indicated by the argument'/ &
      1x, 6a1, ', must be greater than or equal to ', 8a1, '.')
 1090 format( &
     ' the length of ', 6a1, &
     ', as indicated by the argument'/ &
      1x, 6a1, ', must be greater than or equal to ', i6, '.')
end
subroutine eisii ( nmsub, nmvar, ival, ivalmn, ivalmx, msgtyp, &
     head, error, nmmin, nmmax )

!*****************************************************************************80
!
!! EISII warns if an integer value does not lie within a given range.
!
!  Discussion:
!
!    The routine checks whether the value ival is within the
!    the range ivalmn (inclusive) to ivalmx (inclusive), and prints a
!    diagnostic if it is not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer ival
!        the input value of the argument being checked.
!     integer ivalmn, ivalmx
!        the minimum and maximum of the range within which the
!        argument must lie.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is .true. and
!        msgtyp = 1 the input value was outside the range determined
!                   from other input arguments
!        msgtyp = 2 the input value was outside the range imposed by
!                   starpac
!     character*1 nmmax(8)
!        the name of the argument specifying the maximum.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!
  implicit none

  integer &
     ival,ivalmn,ivalmx,msgtyp
  logical &
     error,head
!
!  array arguments
  character &
     nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1

  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (((ivalmn <= ival) .and. (ival <= ivalmx)) .or. &
     (ivalmx<ivalmn)) return

  error = .true.
  call ehdr(nmsub, head)

  if (msgtyp <= 2) write ( *, 1000) (nmvar(i),i=1,6), ival
!
!  print message for value outside of range determined from
!  other input arguments.
!
  if (msgtyp == 1) &
     write ( *, 1010 ) (nmvar(i),i=1,6), (nmmin(i),i=1,8), &
        (nmmax(i),i=1,8)
!
!  print message for value outside of range imposed by starpac
!
  if (msgtyp == 2) &
     write ( *, 1020) (nmvar(i),i=1,6), ivalmn, ivalmx
!
!  print message for aov routines
!
  if (msgtyp == 3) &
     write ( *, 1030)
  return

 1000 format (/' the input value of ', 6a1, ' is ', i6, '.')
 1010 format( &
     ' the value of the argument ', 6a1, &
     ' must be between', 1x, 8a1, &
     ' and ', 8a1, ', inclusive.')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must be between', 1x, i6, &
     ' and ', i6, ', inclusive.')
 1030 format(/' the number of distinct groups (ng) must be between'/ &
    ' two and one less than the number of positive tag values.')

end
subroutine eisle ( nmsub, nmvar1, nval, nmax, msgtyp, head, error, &
     nmvar2 )

!*****************************************************************************80
!
!! EISLE warns if an integer is greater than a given maximum.
!
!  Discussion:
!
!    This routine checks whether the value   nval   is less than
!    or equal to   nmax   and prints a diagnostic if it is not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer nmax
!        the maximum acceptable value for the argument being tested.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is true and
!        msgtyp = 1 the input value was too large based
!                   on limits imposed by starpac
!        msgtyp = 2 the input value was too large based on other input
!                   arguments.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar1(8)
!        the characters of the name of the argument being checked.
!     character*1 nmvar2(8)
!        the characters of the name of the argument being checked
!        against.
!     integer nval
!        the input value of the argument being checked.
!
  implicit none

  integer &
     msgtyp,nmax,nval
  logical &
     error,head
!
!  array arguments
  character &
     nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1

  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (nval <= nmax) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar1(i), i=1,6), nval

  if ( msgtyp == 1 ) then
    write ( *, 1010) (nmvar1(i), i=1,6), nmax
  else if ( msgtyp == 2 ) then
    write ( *, 1020) (nmvar1(i), i=1,6), (nmvar2(i), i=1,8)
  end if

  return

 1000 format (/' the input value of ', 6a1, ' is ', i5, '.')
 1010 format( &
     ' the value of the argument ', 6a1, &
     ' must be less than or equal to ', i5, '.')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must be less than or equal to ', 8a1, '.')

end
subroutine eisrng ( nmsub, iseed, iseedu, head )

!*****************************************************************************80
!
!! EISRNG warns if ISEED is not a suitable random number seed.
!
!  Discussion:
!
!    This routine checks whether the input variable iseed is
!    within [0, 2**mdig], and, if nonzero, is odd.
!
!    if iseed is within [0, 2**mdig] then
!       iseedu = iseed-mod(iseed,2)+1
!    else
!       iseedu = min[ abs(iseed)-mod(abs(iseed),2)+1, 2**(mdig-1)-1]
!                and an error message is printed.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer iseed
!        the value of the seed being tested.
!     integer iseedu
!        the value of the seed actually used by nrand and nrandc.
!     integer mdig
!        a lower bound on the number of binary digits available
!        for representing integers, including the sign bit.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!
  implicit none

  integer &
     iseed,iseedu
  logical &
     head
!
!  array arguments
  character &
     nmsub(6)*1

  integer &
     mdig
!
!  external functions
  integer &
     i1mach
  external i1mach

  mdig = min(i1mach(8)+1,32)
!
!  check for violations
!
  if ((iseed == 0) .or. &
      ((iseed >= 1) .and. &
       (iseed <= 2**(mdig-1)-1) .and. &
       (mod(iseed,2) == 1))) then
!
!  supplied seed will be used
!
     iseedu = iseed

  else
!
!  violations found
!
     iseedu = min( abs(iseed)+mod(abs(iseed),2)-1, 2**(mdig-1)-1)
     call ehdr(nmsub, head)
     write ( *, 1010) mdig-1,iseedu

  end if

  return

 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,'.')

end
subroutine eiveo ( nmsub, nmvar, ivec, n, even, head )

!*****************************************************************************80
!
!! EIVEO checks whether all vector entries are even (or odd).
!
!  Discussion:
!
!    This routine checks whether each of the values in the input
!    vector ivec are even (or odd) and prints a
!    diagnostic if they are not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical even
!        an indicator variable designating whether the values of ivec
!        should be even (true) or not (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ivec(n)
!        the vector being tested.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the parameters name.
!
  implicit none

  integer &
     n
  logical &
     even,head
!
!  array arguments
  integer &
     ivec(*)
  character &
     nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i

  do i = 1, n
     if ((even .and. (mod(ivec(i), 2) == 1)) .or. &
         ((.not.even) .and. (mod(ivec(i), 2) == 1))) go to 20
  end do

  return
!
!  violations found
!
   20 continue

  call ehdr(nmsub, head)

  if ( .not. even ) then
    write ( *, 1010) (nmvar(i), i = 1, 6)
  else
    write ( *, 1020) (nmvar(i), i = 1, 6)
  end if

  return

 1010 format(/ &
     ' the values in the vector ', 6a1, &
     ' must all be odd.  the next'/ &
     ' larger integer will be used in place of even values.')
 1020 format(/ &
     ' the values in the vector ', 6a1, &
     ' must all be even.  the next'/ &
     ' larger integer will be used in place of odd values.')
end
subroutine eiveq ( nmsub, nmvar1, ivec, n, ival, neqmn, head, neq, &
  nne, msgtyp, error, nmvar2, nmvar3 )

!*****************************************************************************80
!
!! EIVEQ warns if the vector does not have at least NEQMN entries equal to IVAL.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ivec(n)
!        the vector being checked.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is true and
!        msgtyp = 1, the input value was too small based on limits
!                    imposed by starpac.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar1(8)
!        the characters of the name of the argument being checked.
!     character*1 nmvar2(8)
!        the characters of the name of the argument being checked
!        against.
!     character*1 nmvar3(8)
!        the characters of the name of the argument that the elements
!        must be equal to.
!     integer neq
!        the number of elements equal to ival.
!     integer neqmn
!        the minimum number of elements equal to ival which is ok.
!     integer nne
!        the number of elements not equal to ival.
!
  implicit none

  integer &
     ival,msgtyp,n,neq,neqmn,nne
  logical &
     error,head
!
!  array arguments
  integer &
     ivec(*)
  character &
     nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1,nmvar3(8)*1
!
!
  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (n <= 0) return
!
!  check for values equal to ival
!
  neq = 0
  do i = 1, n
     if (ivec(i) == ival) neq = neq + 1
  end do

  nne = n - neq
  if (neq  >=  neqmn) return
!
!  insufficient number of elements equal to ival.
!
  error = .true.

  call ehdr(nmsub, head)

  if (msgtyp == 1) write ( *, 1000) &
     (nmvar1(i),i=1,8), (nmvar2(i),i=1,8), neq, &
     (nmvar2(i),i=1,8), (nmvar3(i),i=1,8)

  return

 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, '.')

end
subroutine eivii ( nmsub, nmvar, ivec, n, iveclb, ivecub, nvmx, &
     head, msgtyp, nv, error, nmmin, nmmax )

!*****************************************************************************80
!
!! EIVII warns if too many values are outside given limits.
!
!  Discussion:
!
!    This routine checks for values in the input vector ivec
!    which are outside the (inclusive) limits iveclb to ivecub, prints
!    an error message if the number of violations exceeds the largest
!    number of violations allowed, and returns the number of
!    violations and an error flag indicating the results.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        the value returned from the error checking routines to indicate
!        whether an error was detected (true) or not (false).
!     logical head
!        a flag indicating whether the heading should be printed (true)
!        or not (false).
!     integer i
!        an index argument.
!     integer ivec(n)
!        the vector being tested.
!     integer iveclb, ivecub
!        the (inclusive) range that the vector is being tested
!        against.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 4) the message printed will use nmmin and
!        nmmax, otherwise it will use iveclb and ivecub.
!        if (msgtyp = 1 or 4) no violations are allowed.
!        if (msgtyp = 2 or 5) the number of violations must
!                             be less than   nvmx   .
!        if (msgtyp = 3 or 6) violations are counted only if the
!                             the first element is not in violation.
!     integer n
!        the number of observations.
!     character*1 nmmax(8)
!        the name of the argument specifying the maximum.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!
  implicit none

  integer &
     iveclb,ivecub,msgtyp,n,nv,nvmx
  logical &
     error,head
!
!  array arguments
  integer &
     ivec(*)
  character &
     nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
  integer &
     i

  error = .false.

  if (n <= 0) return
  if (ivecub<iveclb) return
!
!  test whether testing is necessry
!
  if ((mod(msgtyp,3) == 0) .and. &
      ((ivec(1) < iveclb) .or. (ivec(1) > ivecub))) return
!
!  check for violations
!
  nv = 0
  do i = 1, n
     if ((ivec(i)<iveclb) .or. (ivec(i) > ivecub)) nv = nv + 1
  end do

  if (nv <= nvmx) return
!
!  violations found
!
  error = .true.
  call ehdr(nmsub, head)

  if (msgtyp <= 3) then
     write ( *, 1000) (nmvar(i),i=1,6), iveclb, ivecub, nv
  else
     write ( *, 1005) (nmvar(i),i=1,6), (nmmin(i),i=1,8), &
     (nmmax(i),i=1,8), nv
  end if

  if ( msgtyp == 1 .or. msgtyp == 4 ) then
    write ( *, 1010) (nmvar(i),i=1,6)
  else if ( msgtyp == 2 .or. msgtyp == 5 ) then
    write ( *, 1020) (nmvar(i),i=1,6), nvmx
  else if ( msgtyp == 3 .or. msgtyp == 6 ) then
    write ( *, 1030) (nmvar(i),i=1,6)
  end if

  return

 1000 format (/ &
     ' the number of values in vector ', 6a1, &
     ' outside the range ', i6, ' to'/ &
     1x, i6, ', inclusive, is ', i6, '.')
 1005 format (/ &
     ' the number of values in vector ', 6a1, &
     ' outside the range ', 8a1, ' to'/ &
     1x, 8a1, ', inclusive, is ', i6, '.')
 1010 format( &
     ' the values in the vector ', 6a1, &
     ' must all be within this range.')
 1020 format( &
     ' the number of values in the vector ', 6a1, &
     ' outside this range'/ &
     ' must be less than ', i5, '.')
 1030 format( &
     ' if the first value of the vector ', 6a1, &
     ' is within this range'/ &
     ' all of the values must be within this range.')
end
subroutine enfft ( nmsub, nfft, ndiv, n, lyfft, nfft2, head, error )

!*****************************************************************************80
!
!! ENFFT checks that NFFT is suitable for the Singleton FFT routine.
!
!  Discussion:
!
!    This routine checks whether the value nfft is such that nfft-2 is
!    divisible by ndiv and has no prime factors greater than 23, and
!    the product of the square free prime factors of nfft - 2 do not
!    exceed 209, i.e., the value of nfft meets the requirements of
!    the extended length of the series required for any routine
!    using the singleton fft providing the proper value of ndiv
!    is chosen.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer lyfft
!        the length of the vector containing the series to be extended.
!     integer n
!        the actual number of observations in the series.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     integer nfft
!        the user supplied extended series length.
!     integer nfft1
!        the maximum of nfft and n+2.
!     integer nfft2
!        the smallest extended series length which equals or
!        exceeds nfft and which meets the requirements of
!        singletons fft code.
!
  implicit none

  integer &
     lyfft,n,ndiv,nfft,nfft2
  logical &
     error,head
!
!  array arguments
  character &
     nmsub(6)*1
!
!
  integer &
    nfft1

  error = .false.
!
!  print warning
!
  if ( nfft < n + 2 ) then
    call ehdr(nmsub, head)
    write ( *, 1050) n
  end if

  nfft1 = max(nfft, n+2)
  call setesl(nfft1-2, ndiv, nfft2)

  if (nfft == nfft2) return
!
!  print warning
!
  call ehdr(nmsub, head)

  write ( *, 1020) nfft, nfft2

  if ( nfft <= lyfft ) then
    write ( *, 1030) nfft2
    return
  end if

  error = .true.

  write ( *, 1040) nfft2, lyfft
  return

 1020 format (/ &
     ' the input value of the parameter nfft (', i5, &
     ') does not meet'/ &
     ' the requirements of singletons fft code.  the next', &
     ' larger value'/ &
     ' which does is ', i5, '.')
 1030 format (/ &
     ' the value ', i5, ' will be used for the extended series', &
      ' length.')
 1040 format (/ &
     ' however, the value ', i5, ' exceeds the length lyfft (', &
     i5, ') of the'/ &
     ' vector yfft, and therefore cannot be used as the extended'/ &
     ' series length without redimensioning yfft.')
 1050 format (/ &
     ' the extended series length (nfft) must equal or exceed,'/ &
     ' the number of observations in the series (n=', i5, ' plus 2.')
end
subroutine eprint ( )

!*****************************************************************************80
!
!! EPRINT prints the last error message, if any.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  character messg(1)*4

  call e9rint(messg,1,1,.false.)

  return
end
subroutine eragt ( nmsub, nmvar, ym, n, m, iym, ymmn, nvmx, &
     head, msgtyp, nv, error, nmmin )

!*****************************************************************************80
!
!! ERAGT warns if too many values are less than a lower bound.
!
!  Discussion:
!
!    This routine checks to ensure that no values, or only a maximum
!    of nvmx, are not greater than a specified lower bound ymmn,
!    with name nmmin.   the checking option is specified
!    with msgtyp.  if an error is found, the error is printed and
!    an error flag and the number of violatins are returned.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer iym
!        the first dimension of the array ym.
!     integer j
!        an indexing variable.
!     integer m
!        the number of columns of data in ym.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 3) the message printed will use nmmin
!        otherwise it will use ymmn.
!        if (msgtyp = 1 or 3) no violations are allowed.
!        if (msgtyp = 2 or 4) the number of violations must
!                             be less than   nvmx   .
!     integer n
!        the number of observations.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     character*1 nmvar(8)
!        the characters of the parameters name.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!     real ym(iym,m)
!        the array being tested.
!     real ymmn
!        the minimum acceptable value.
!
  implicit none

  real &
     ymmn
  integer &
     iym,m,msgtyp,n,nv,nvmx
  logical &
     error,head
!
!  array arguments
  real &
     ym(*)
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1

  integer &
     i,j
!
!  external subroutines
  external eragtp

  error = .false.

  if ((n <= 0) .or. (m <= 0)) return
!
!  check for violations
!
  nv = 0
  do i = 1, n
    do j = 1, m
      if (ym(i+(j-1)*iym) <= ymmn) nv = nv + 1
    end do
  end do

  if (nv <= nvmx) return
!
!  violations found
!
  error = .true.

  call eragtp (nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, &
     nmmin)

  return
end
subroutine eragtm ( nmsub, nmvar, ym, ymmiss, n, m, iym, ymmn, &
     nvmx, head, msgtyp, nv, error, nmmin )

!*****************************************************************************80
!
!! ERAGTM warns if too many values are less than or equal to a lower bound.
!
!  Discussion:
!
!    This routine checks to ensure that no values, or only a maximum
!    of nvmx, are not greater than a specified lower bound ymmn,
!    with name nmmin.   the checking option is specified
!    with msgtyp.  if an error is found, the error is printed and
!    an error flag and the number of violatins are returned.
!    elements of ym(*, i) equal to ymmiss(i) are exempt from checking.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer iym
!        the first dimension of the array ym.
!     integer m
!        the number of columns of data in ym.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 3) the message printed will use nmmin
!        otherwise it will use ymmn.
!        if (msgtyp = 1 or 3) no violations are allowed.
!        if (msgtyp = 2 or 4) the number of violations must
!                             be less than   nvmx   .
!     integer n
!        the number of observations.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     character*1 nmvar(8)
!        the characters of the parameters name.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!     real ym(iym,m)
!        the array being tested.
!     real ymmiss(m)
!        missing value codes for each column of ym
!     real ymmn
!        the minimum acceptable value.
!
  implicit none

  real &
     ymmn
  integer &
     iym,m,msgtyp,n,nv,nvmx
  logical &
     error,head
!
!  array arguments
  real &
     ym(*),ymmiss(*)
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1

  integer &
     i,j
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  external subroutines
  external eragtp

  error = .false.

  if ((n <= 0) .or. (m <= 0)) return
!
!  check for violations
!
  nv = 0
  do i = 1, n
    do j = 1, m
      if ( .not. mvchk(ym(i+(j-1)*iym), ymmiss(j))) then
        if (ym(i+(j-1)*iym) <= ymmn) nv = nv + 1
      end if
    end do
  end do

  if (nv <= nvmx) then
    return
  end if
!
!  violations found
!
  error = .true.
  call eragtp (nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, &
     nmmin)

  return
end
subroutine eragtp ( nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, nmmin )

!*****************************************************************************80
!
!! ERAGTP prints the error messages for ERAGT and ERAGTM.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 3) the message printed will use nmmin
!        otherwise it will use ymmn.
!        if (msgtyp = 1 or 3) no violations are allowed.
!        if (msgtyp = 2 or 4) the number of violations must
!                             be less than   nvmx   .
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     character*1 nmvar(8)
!        the characters of the parameters name.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!     real ymmn
!        the minimum acceptable value.
!
  implicit none

  real &
     ymmn
  integer &
     msgtyp,nv,nvmx
  logical &
     head
!
!  array arguments
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1

  integer &
     i
!
!  external subroutines
  external ehdr
!
  call ehdr(nmsub, head)

  if (msgtyp <= 2) then
     write ( *, 1000) (nmvar(i),i=1,6), ymmn, nv
  else
     write ( *, 1005) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv
  end if

  if ( msgtyp == 1 ) then
    write ( *, 1010) (nmvar(i),i=1,6), ymmn
  else if ( msgtyp == 2 ) then
    write ( *, 1020) (nmvar(i),i=1,6), ymmn, nvmx
  else if ( msgtyp == 3 ) then
    write ( *, 1030) (nmvar(i),i=1,6), (nmmin(i),i=1,8)
  else if ( msgtyp ==4 ) then
    write ( *, 1040) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nvmx
  end if

  return

 1000 format (/ &
     ' the number of values in array ', 6a1, &
     ' less than or equal to ', 1pe14.7, ' is ', i6, '.')
 1005 format (/ &
     ' the number of values in array ', 6a1, &
     ' less than or equal to ', 8a1, ' is ', i6, '.')
 1010 format( &
     ' the values in the array ', 6a1, &
     ' must all be greater than ', 1pe14.7, '.')
 1020 format( &
     ' the number of values in the array ', 6a1, &
     ' less than or equal to ', 8a1/ &
     ' must be less than ', i5, '.')
 1030 format( &
     ' the values in the array ', 6a1, &
     ' must all be greater than ', 1pe14.7, '.')
 1040 format( &
     ' the number of values in the array ', 6a1, &
     ' less than or equal to ', 8a1/ &
     ' must be less than ', i5, '.')

end
subroutine erdf ( nmsub, ndf, iod, nd, n, head, error )

!*****************************************************************************80
!
!! ERDF checks the values that specify differencing on a time series.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ier
!        an error indicator.
!     integer iod(ndf)
!        the vector containing the orders of each difference factor.
!     integer mbod
!        the maximum backorder due to differencing.
!     integer n
!        the integer number of observations in each series
!     integer nd(ndf)
!        the vector containing the number of times each difference
!        factor is applied.
!     integer ndf
!        the number of difference factors to be applied to the series.
!     character*1 nmsub(6)
!        the characters of the calling subroutine name.
!
  implicit none

  integer &
     n,ndf
  logical &
     error,head
!
!  array arguments
  integer &
     iod(*),nd(*)
  character &
     nmsub(6)*1
  integer &
     i,ier,mbod
!
!  external subroutines
  external ehdr

  error = .false.

  if (ndf < 0) then
    call ehdr(nmsub, head)
    write ( *, 1001) ndf
    error = .true.
    return
  end if

  if (ndf == 0) return

  ier = 0
  mbod = 0
  do i = 1, ndf
     if ( iod(i)  >=  1 .and. nd(i)  >=  1) go to 20
     ier = 1
     go to 40
   20    mbod = mbod + iod(i) * nd(i)
  end do

  if (mbod <= n - 1) return

   40 continue

  call ehdr(nmsub, head)
  if (ier == 1) &
     write ( *, 1002) (i, nd(i), iod(i), i = 1, ndf)
  if (ier == 0 .and. mbod  >=  n) write ( *, 1003) mbod, n
  error = .true.
  return

 1001 format(/' the number of difference factors (ndf) must'/ &
     ' be greater than or equal to zero.  the input value of'/ &
     ' ndf is ', i6, '.')
 1002 format (/' the order of each difference factor (iod) and'/ &
     ' number of times it is applied (nd) must be greater than'/ &
     ' equal to one.  the input values of these arrays are'/ &
     '    dif. fact.   nd   iod'/ &
     (1x, i13, i5, i6))
 1003 format (/' the maximum backorder due to differencing (mbod)', &
    /' that is, the sum of nd(i)*iod(i), i = 1, 2, ..., ndf,'/ &
     ' must be less than or equal to n-1.  the computed value for'/ &
     ' mbod is ', i6, ', while the input value for n is ', i6, '.')
end
function erfc ( x )

!*****************************************************************************80
!
!! ERFC evaluates the complementary error function.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!  variable declarations
!
  implicit none

  real erfc
  real x
!
!
  real eta,sqeps,sqrtpi,xmax,xsml,y
  integer nterc2,nterf,nterfc
!
!  local arrays
  real erc2cs(23),erfccs(24),erfcs(13)
!
!  external functions
  real csevl
  integer inits
  external csevl,inits
!
!
! series for erf        on the interval  0.          to  1.00000d+00
!                                        with weighted error   7.10e-18
!                                         log weighted error  17.15
!                               significant figures required  16.31
!                                    decimal places required  17.71
!
  data erfcs( 1) /   -.049046121234691808e0 /
  data erfcs( 2) /   -.14226120510371364e0 /
  data erfcs( 3) /    .010035582187599796e0 /
  data erfcs( 4) /   -.000576876469976748e0 /
  data erfcs( 5) /    .000027419931252196e0 /
  data erfcs( 6) /   -.000001104317550734e0 /
  data erfcs( 7) /    .000000038488755420e0 /
  data erfcs( 8) /   -.000000001180858253e0 /
  data erfcs( 9) /    .000000000032334215e0 /
  data erfcs(10) /   -.000000000000799101e0 /
  data erfcs(11) /    .000000000000017990e0 /
  data erfcs(12) /   -.000000000000000371e0 /
  data erfcs(13) /    .000000000000000007e0 /
!
! series for erfc       on the interval  0.          to  2.50000d-01
!                                        with weighted error   4.81e-17
!                                         log weighted error  16.32
!                        approx significant figures required  15.0
! series for erc2       on the interval  2.50000d-01 to  1.00000d+00
!                                        with weighted error   5.22e-17
!                                         log weighted error  16.28
!                        approx significant figures required  15.0
!                                    decimal places required  16.96
!
  data erc2cs( 1) /   -.069601346602309501e0 /
  data erc2cs( 2) /   -.041101339362620893e0 /
  data erc2cs( 3) /    .003914495866689626e0 /
  data erc2cs( 4) /   -.000490639565054897e0 /
  data erc2cs( 5) /    .000071574790013770e0 /
  data erc2cs( 6) /   -.000011530716341312e0 /
  data erc2cs( 7) /    .000001994670590201e0 /
  data erc2cs( 8) /   -.000000364266647159e0 /
  data erc2cs( 9) /    .000000069443726100e0 /
  data erc2cs(10) /   -.000000013712209021e0 /
  data erc2cs(11) /    .000000002788389661e0 /
  data erc2cs(12) /   -.000000000581416472e0 /
  data erc2cs(13) /    .000000000123892049e0 /
  data erc2cs(14) /   -.000000000026906391e0 /
  data erc2cs(15) /    .000000000005942614e0 /
  data erc2cs(16) /   -.000000000001332386e0 /
  data erc2cs(17) /    .000000000000302804e0 /
  data erc2cs(18) /   -.000000000000069666e0 /
  data erc2cs(19) /    .000000000000016208e0 /
  data erc2cs(20) /   -.000000000000003809e0 /
  data erc2cs(21) /    .000000000000000904e0 /
  data erc2cs(22) /   -.000000000000000216e0 /
  data erc2cs(23) /    .000000000000000052e0 /
!
!                                    decimal places required  17.01
!
  data erfccs( 1) /   0.0715179310202925e0 /
  data erfccs( 2) /   -.026532434337606719e0 /
  data erfccs( 3) /    .001711153977920853e0 /
  data erfccs( 4) /   -.000163751663458512e0 /
  data erfccs( 5) /    .000019871293500549e0 /
  data erfccs( 6) /   -.000002843712412769e0 /
  data erfccs( 7) /    .000000460616130901e0 /
  data erfccs( 8) /   -.000000082277530261e0 /
  data erfccs( 9) /    .000000015921418724e0 /
  data erfccs(10) /   -.000000003295071356e0 /
  data erfccs(11) /    .000000000722343973e0 /
  data erfccs(12) /   -.000000000166485584e0 /
  data erfccs(13) /    .000000000040103931e0 /
  data erfccs(14) /   -.000000000010048164e0 /
  data erfccs(15) /    .000000000002608272e0 /
  data erfccs(16) /   -.000000000000699105e0 /
  data erfccs(17) /    .000000000000192946e0 /
  data erfccs(18) /   -.000000000000054704e0 /
  data erfccs(19) /    .000000000000015901e0 /
  data erfccs(20) /   -.000000000000004729e0 /
  data erfccs(21) /    .000000000000001432e0 /
  data erfccs(22) /   -.000000000000000439e0 /
  data erfccs(23) /    .000000000000000138e0 /
  data erfccs(24) /   -.000000000000000048e0 /

  data sqrtpi /1.7724538509055160e0/
  data nterf, nterfc, nterc2, xsml, xmax, sqeps /3*0, 3*0./

  if ( nterf == 0 ) then
    eta = 0.05 * epsilon ( eta )
    nterf = inits (erfcs, 13, eta)
    nterfc = inits (erfccs, 24, eta)
    nterc2 = inits (erc2cs, 23, eta)
    xsml = -sqrt (-log(sqrtpi* 0.5 * epsilon ( xsml ) ))
    xmax = sqrt (-log(sqrtpi* tiny ( xmax ) ))
    xmax = xmax - 0.5*log(xmax)/xmax - 0.01
    sqeps = sqrt ( epsilon ( sqeps ) )
  end if
!
! erfc(x) = 1.0 - erf(x) for x < xsml
!
  if ( x <= xsml ) then
    erfc = 2.0
    return
  end if

  if (x > xmax) go to 40
  y = abs(x)
  if (y > 1.0) go to 30
!
! erfc(x) = 1.0 - erf(x) for -1. <= x <= 1.
!
  if (y<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
!
  return
!
! erfc(x) = 1.0 - erf(x) for 1. < abs(x) <= xmax
!
 30   y = y*y
  if (y <= 4.0 ) 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<0.0) erfc = 2.0 - erfc
  return

 40   call xerror ('erfc    x so big erfc underflows', 1, 1)
  erfc = 0.0

  return
end
function erf ( x )

!*****************************************************************************80
!
!! ERF evaluates the error function.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!  variable declarations
!
  implicit none

  real erf
  real x
!
!
  real sqeps,sqrtpi,xbig,y
  integer nterf
!
!  local arrays
  real erfcs(13)
!
!  external functions
  real csevl,erfc
  integer inits
  external csevl,erfc,inits
!
!
! series for erf        on the interval  0.          to  1.00000d+00
!                                        with weighted error   7.10e-18
!                                         log weighted error  17.15
!                               significant figures required  16.31
!                                    decimal places required  17.71
!
  data erfcs( 1) /   -.049046121234691808e0 /
  data erfcs( 2) /   -.14226120510371364e0 /
  data erfcs( 3) /    .010035582187599796e0 /
  data erfcs( 4) /   -.000576876469976748e0 /
  data erfcs( 5) /    .000027419931252196e0 /
  data erfcs( 6) /   -.000001104317550734e0 /
  data erfcs( 7) /    .000000038488755420e0 /
  data erfcs( 8) /   -.000000001180858253e0 /
  data erfcs( 9) /    .000000000032334215e0 /
  data erfcs(10) /   -.000000000000799101e0 /
  data erfcs(11) /    .000000000000017990e0 /
  data erfcs(12) /   -.000000000000000371e0 /
  data erfcs(13) /    .000000000000000007e0 /

  data sqrtpi /1.7724538509055160e0/
  data nterf, xbig, sqeps / 0, 0., 0./

  if ( nterf == 0 ) then
    nterf = inits (erfcs, 13, 0.05 * epsilon ( x ) )
    xbig = sqrt ( -log ( sqrtpi * 0.5 * epsilon ( xbig )  ) )
    sqeps = sqrt( epsilon ( sqeps ) )
  end if

  y = abs(x)

  if ( y <= 1.0 ) then

    if (y <= sqeps) then
      erf = 2.0*x/sqrtpi
    else
      erf = x*(1.0 + csevl(2.*x**2-1., erfcs, nterf))
    end if

  else

    if (y <= xbig) then
      erf = sign (1.0-erfc(y), x)
    else
      erf = sign (1.0, x)
    end if

  end if

  return
end
subroutine eriodd ( nmsub, nmvar, nval, msgtyp, head, error )

!*****************************************************************************80
!
!! ERIODD warns if the value of NVAL is inconsistent.
!
!  Discussion:
!
!    This routine sets error to true if the value   nval   is not even
!    or odd, as specified by the parameter odd.  in addition, if this
!    is the first error found for the calling subroutine   nmsub   , ie
!    if   head   is true, then a heading for the calling subroutine
!    is also printed out.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer msgtyp
!        a variable used to indicate the type of message to be
!        printed, where if
!        msgtyp = 1, the input value should be odd and
!        msgtyp = 2, the input value should be even.
!     character*1 nmsub(6)
!        the array containing the name of the calling subroutine.
!     character*1 nmvar(8)
!        the array containing the name of the variable being checked.
!     integer nval
!        the value of the variable being checked.
!
  implicit none

  integer &
     msgtyp,nval
  logical &
     error,head
!
!  array arguments
  character &
     nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i

  error = .false.

  if ( msgtyp /= 2 ) then

    if ( mod ( nval, 2 ) /= 1 ) then
      call ehdr(nmsub, head)
      write ( *, 1010) (nmvar(i), i = 1, 6), (nmvar(i), i = 1, 6), nval
      error = .true.
    end if

  else

    if ( mod ( nval, 2 ) /= 0 ) then
      call ehdr(nmsub, head)
      write ( *, 1020) (nmvar(i), i = 1, 6), (nmvar(i), i = 1, 6), nval
      error = .true.
    end if

  end if

  return

 1010 format(/ &
     ' the value of the variable ', 6a1, &
     ' must be odd.  the input value of ', 6a1/ &
      ' is ', i5, '.')
 1020 format(/ &
     ' the value of the variable ', 6a1, &
     ' must be even.  the input value of ', 6a1/ &
      ' is ', i5, '.')
end
subroutine ersei ( nmsub, nmvar, val, valmn, valmx, msgtyp, head, &
     error, nmmin, nmmax )

!*****************************************************************************80
!
!! ERSEI warns if a value is not between given limits.
!
!  Discussion:
!
!    This routine checks whether the value   val   is within the
!    the range valmn (exclusive) to valmx (inclusive), and prints a
!    diagnostic if it is not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is .true. and
!        msgtyp = 1 the input value was outside the range determined
!                   from other input arguments
!        msgtyp = 2 the input value was outside the range imposed by
!                   starpac
!     character*1 nmmax(8)
!        the name of the argument specifying the maximum.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     real val
!        the input value of the argument being checked.
!     real valmn, valmx
!        the minimum and maximum of the range within which the
!        argument must lie.
!
  implicit none

  real &
     val,valmn,valmx
  integer &
     msgtyp
  logical &
     error,head
!
!  array arguments
  character &
     nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (((valmn<val) .and. (val <= valmx)) .or. &
     (valmx<valmn)) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar(i),i=1,6), val
!
!  print message for value outside of range determined from
!  other input arguments.
!
  if (msgtyp == 1) &
     write ( *, 1010) (nmvar(i),i=1,6), (nmmin(i),i=1,8), &
        (nmmax(i),i=1,8)
!
!  print message for value outside of range imposed by starpac
!
  if (msgtyp == 2) &
     write ( *, 1020) (nmvar(i),i=1,6), valmn, valmx
  return

 1000 format (/' the input value of ', 6a1, ' is ', g15.8, '.')
 1010 format ( &
     ' the value of the argument ', 6a1, &
     ' must lie between', 1x, 8a1, ' (exclusive)'/ &
     ' and ', 8a1, ' (inclusive).')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must lie between', 1x, g15.8, ' (exclusive)'/ &
     ' and ', g15.8, ' (inclusive).')

end
subroutine ersge ( nmsub, nmvar, val, valmn, msgtyp, head, error, nmmin )

!*****************************************************************************80
!
!! ERSGE warns if a value is not greater than or equal to a minimum value.
!
!  Discussion:
!
!    This routine checks whether the value val is greater than or
!    equal to valmn, and prints a diagnostic if it is not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is .true. and
!        msgtyp = 1 the input value was too small based
!                   on limits imposed by starpac
!        msgtyp = 2 the input value was too small based on
!                   limits based on other input arguments.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     real val
!        the input value of the argument being checked.
!     real valmn
!        the minimum value the argument can validly have.
!
  implicit none

  real &
     val,valmn
  integer &
     msgtyp
  logical &
     error,head
!
!  array arguments
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (val  >=  valmn) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar(i),i=1,6), val

  if ( msgtyp == 1 ) then
    write ( *, 1010) (nmvar(i),i=1,6), valmn
  else if ( msgtyp == 2 ) then
    write ( *, 1020) (nmvar(i),i=1,6), (nmmin(i),i=1,8)
  end if

  return

 1000 format (/' the input value of ', 6a1, ' is ', g15.8, '.')
 1010 format( &
     ' the value of the argument ', 6a1, &
     ' must be greater than or equal to ', g21.14, '.')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must be greater than or equal to ', 8a1, '.')
end
subroutine ersgt ( nmsub, nmvar, val, valmn, msgtyp, head, error, nmmin )

!*****************************************************************************80
!
!! ERSGT warns if the input value is not greater than a specified minumum.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is .true. and
!        msgtyp = 1 the input value was too small based
!                   on limits imposed by starpac
!        msgtyp = 2 the input value was too small based on
!                   limits based on other input arguments.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     real val
!        the input value of the argument being checked.
!     real valmn
!        the minimum value the argument can validly have.
!
  implicit none

  real &
     val,valmn
  integer &
     msgtyp
  logical &
     error,head
!
!  array arguments
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (val > valmn) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar(i),i=1,6), val

  if ( msgtyp == 1 ) then
    write ( *, 1010) (nmvar(i),i=1,6), valmn
  else
    write ( *, 1020) (nmvar(i),i=1,6), (nmmin(i),i=1,8)
  end if

  return

 1000 format (/' the input value of ', 6a1, ' is ', g15.8, '.')
 1010 format( &
     ' the value of the argument ', 6a1, &
     ' must be greater than ', g21.14, '.')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must be greater than ', 8a1, '.')
end
subroutine ersie ( nmsub, nmvar, val, valmn, valmx, msgtyp, head, &
     error, nmmin, nmmax )

!*****************************************************************************80
!
!! ERSIE warns if a value is not within a specified range.
!
!  Discussion:
!
!    This routine checks whether the value   val   is within the
!    the range valmn (inclusive) to valmx (exclusive), and prints a
!    diagnostic if it is not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is .true. and
!        msgtyp = 1 the input value was outside the range determined
!                   from other input arguments
!        msgtyp = 2 the input value was outside the range imposed by
!                   starpac
!     character*1 nmmax(8)
!        the name of the argument specifying the maximum.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     real val
!        the input value of the argument being checked.
!     real valmn, valmx
!        the minimum and maximum of the range within which the
!        argument must lie.
!
  implicit none

  real &
     val,valmn,valmx
  integer &
     msgtyp
  logical &
     error,head
!
!  array arguments
  character &
     nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (((valmn <= val) .and. (val<valmx)) .or. &
     (valmx<valmn)) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar(i),i=1,6), val
!
!  print message for value outside of range determined from
!  other input arguments.
!
  if (msgtyp == 1) &
     write ( *, 1010) (nmvar(i),i=1,6), (nmmin(i),i=1,8), &
        (nmmax(i),i=1,8)
!
!  print message for value outside of range imposed by starpac
!
  if (msgtyp == 2) &
     write ( *, 1020) (nmvar(i),i=1,6), valmn, valmx
  return

 1000 format (/' the input value of ', 6a1, ' is ', g15.8, '.')
 1010 format( &
     ' the value of the argument ', 6a1, &
     ' must lie between', 1x, 8a1, ' (inclusive)'/ &
     ' and ', 8a1, ' (exclusive).')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must lie between', 1x, g15.8, ' (inclusive)'/ &
     ' and ', g15.8, ' (exclusive).')
end
subroutine ersii ( nmsub, nmvar, val, valmn, valmx, msgtyp, head, &
     error, nmmin, nmmax )

!*****************************************************************************80
!
!! ERSII warns if the input value is not within the given range.
!
!  Discussion:
!
!    This routine checks whether the value   val   is within the
!    the range valmn (inclusive) to valmx (inclusive), and prints a
!    diagnostic if it is not.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is .true. and
!        msgtyp = 1 the input value was outside the range determined
!                   from other input arguments
!        msgtyp = 2 the input value was outside the range imposed by
!                   starpac
!     character*1 nmmax(8)
!        the name of the argument specifying the maximum.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     real val
!        the input value of the argument being checked.
!     real valmn, valmx
!        the minimum and maximum of the range within which the
!        argument must lie.
!
  implicit none

  real &
     val,valmn,valmx
  integer &
     msgtyp
  logical &
     error,head
!
!  array arguments
  character &
     nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i
!
!  external subroutines
  external ehdr

  error = .false.

  if (((valmn <= val) .and. (val <= valmx)) .or. &
     (valmx<valmn)) return

  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1000) (nmvar(i),i=1,6), val
!
!  print message for value outside of range determined from
!  other input arguments.
!
  if (msgtyp == 1) &
     write ( *, 1010) (nmvar(i),i=1,6), (nmmin(i),i=1,8), &
        (nmmax(i),i=1,8)
!
!  print message for value outside of range imposed by starpac
!
  if (msgtyp == 2) &
     write ( *, 1020) (nmvar(i),i=1,6), valmn, valmx
  return

 1000 format (/' the input value of ', 6a1, ' is ', g15.8, '.')
 1010 format( &
     ' the value of the argument ', 6a1, &
     ' must be between', 1x, 8a1, &
     ' and ', 8a1, ', inclusive.')
 1020 format( &
     ' the value of the argument ', 6a1, &
     ' must be between', 1x, g15.8, &
     ' and ', g15.8, ', inclusive.')
end
subroutine erslf ( nmsub, nmvar, k, h, head, error )

!*****************************************************************************80
!
!! ERSLF checks the definition of a symmetric linear filter.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real h(k)
!         the vector of filter coefficients.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer ihm, ihp
!        index variables for symmetric locations around the midpoint
!        of the filter.
!     integer k
!        the number of terms in the filter.
!     integer khalf
!        the value of the midpoint of k minus 1.
!     integer kmid
!        the midpoint of the filter.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     character*1 nmvar(8)
!        the array containing the name of the filter coefficient
!        array.
!     integer nzero
!        the number of filter coefficients equal to zero.
!
  implicit none

  integer &
     k
  logical &
     error,head
!
!  array arguments
  real &
     h(*)
  character &
     nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i,ihm,ihp,khalf,kmid,nzero
!
!  external subroutines
  external ehdr

  error = .false.

  kmid = (k + 1) / 2
  khalf = kmid - 1
  nzero = 0

  do ihm = 1, khalf

    ihp = k + 1 - ihm
    if (h(ihm) == 0.0e0) nzero = nzero + 1

    if ( h(ihm) /=  h(ihp) ) then
       call ehdr(nmsub, head)
       write ( *, 1010) (nmvar(i), i = 1, 6), (h(i), i = 1, k)
       error = .true.
       return
    end if

  end do

  if (h(kmid) == 0.0e0) then
    nzero = nzero + 1
  end if

  if (nzero < kmid) then
    return
  end if

  call ehdr(nmsub, head)
  write ( *, 1020) (nmvar(i), i = 1, 6)
  error = .true.

  return

 1010 format(/ &
     ' the input filter ', 6a1, ' must be symmetric.  the', &
     ' input filter coefficients are'/ &
     5(1x, e15.5))
 1020 format(/ &
     ' all the filter coefficients in ', 6a1, ' are identically', &
     ' equal to zero,'/ &
     ' therefore no filtering will be performed.')
end
subroutine erslfs ( nmsub, fc, k, head, error )

!*****************************************************************************80
!
!! ERSLFS checks values specifying a symmetric linear filter for a time series.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real fc
!        the user supplied cutoff frequency.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer k
!        the number of terms in the filter.
!     character*1 nmsub(6)
!        the array containing the name of the calling subroutine.
!
  implicit none

  real &
     fc
  integer &
     k
  logical &
     error,head
!
!  array arguments
  character &
     nmsub(6)*1
!
!  external subroutines
  external ehdr

  if ( fc - 1.0e0/ real ( k ) < 0.0e0 ) then

    call ehdr(nmsub, head)
    write ( *, 1010) fc, k
    error = .true.

  else if ( 0.5 <= fc + 1.0e0 / real ( k )  ) then

    call ehdr(nmsub, head)
    write ( *, 1020) fc, k
    error = .true.

  else

    error = .false.

  end if

  return

 1010 format (/' the cutoff frequency, fc, minus one', &
     ' over the number of filter terms, k, that'/ &
     ' is, fc - 1/k, must be greater than or equal to zero.', &
     ' the input values of fc and k'/ &
     ' are', f8.5, ' and', i5, ', respectively.')
 1020 format (/' the cutoff frequency, fc, plus one', &
     ' over the number of filter terms, k, that is,'/ &
     ' fc + 1/k, must be greater than or equal to zero.', &
     ' the input values of fc and k'/ &
     ' are', f7.5, ' and', i5, ', respectively.')
end
subroutine ervgt ( nmsub, nmvar, vec, n, veclb, nvmx, &
     head, msgtyp, nv, error, nmmin )

!*****************************************************************************80
!
!! ERVGT ensures that "most" values are greater than a specified lower bound.
!
!  Discussion:
!
!    This routine checks to ensure that no values, or only a maximum
!    of nvmx, are not greater than a specified lower bound veclb,
!    with name nmmin. the routine alternatively checks to make sure
!    that no values are in violation of this lower bound if the first
!    value in the vector is not.  the checking option is specified
!    with msgtyp.  if an error is found, the error is printed and
!    an error flag and the number of violatins are returned.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        the value returned from the error checking routines to indicate
!        whether an error was detected (true) or not (false).
!     logical head
!        a flag indicating whether the heading should be printed (true)
!        or not (false).
!     integer i
!        an index argument.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 4) the message printed will use nmmin
!        otherwise it will use veclb.
!        if (msgtyp = 1 or 4) no violations are allowed.
!        if (msgtyp = 2 or 5) the number of violations must
!                             be less than   nvmx   .
!        if (msgtyp = 3 or 6) violations are counted only if the
!                             the first element is not in violation.
!     integer n
!        the number of observations.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     integer nv
!        the number of violations found.
!     integer nvmn
!        the smallest number of non-violations allowed.
!     integer nvmx
!        the largest number of violations allowed.
!     real vec(n)
!        the vector being tested.
!     real veclb
!        the value that the vector is being tested against.
!
  implicit none

  real &
     veclb
  integer &
     msgtyp,n,nv,nvmx
  logical &
     error,head
!
!  array arguments
  real &
     vec(*)
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i,nvmn
!
!  external subroutines
  external ervgtp

  error = .false.

  if (n <= 0) return
!
!  test whether testing is necessry
!
  if ((mod(msgtyp,3) == 0) .and. (vec(1) <= veclb)) return
!
!  check for violations
!
  nv = 0
  do i = 1, n
     if ((vec(i) <= veclb)) nv = nv + 1
  end do

  if (nv <= nvmx) return
!
!  violations found
!
  error = .true.
  nvmn = n - nvmx
  call ervgtp (nmsub, nmvar, veclb, nvmn, nvmx, head, msgtyp, nv, &
     nmmin)

  return
end
subroutine ervgtm ( nmsub, nmvar, vec, vcmiss, n, veclb, nvmx, &
     head, msgtyp, nv, error, nmmin )

!*****************************************************************************80
!
!! ERVGTM ensures that "most" values are greater than a specified lower bound.
!
!  Discussion:
!
!    This routine checks to ensure that no values, or only a maximum
!    of nvmx, are not greater than a specified lower bound veclb,
!    with name nmmin. the routine alternatively checks to make sure
!    that no values are in violation of this lower bound if the first
!    value in the vector is not.  the checking option is specified
!    with msgtyp.  if an error is found, the error is printed and
!    an error flag and the number of violatins are returned.
!    values of vec equal to vcmiss are exempted from the checking.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        the value returned from the error checking routines to indicate
!        whether an error was detected (true) or not (false).
!     logical head
!        a flag indicating whether the heading should be printed (true)
!        or not (false).
!     integer i
!        an index argument.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 4) the message printed will use nmmin
!        otherwise it will use veclb.
!        if (msgtyp = 1 or 4) no violations are allowed.
!        if (msgtyp = 2 or 5) the number of violations must
!                             be less than   nvmx   .
!        if (msgtyp = 3 or 6) violations are counted only if the
!                             the first element is not in violation.
!     integer n
!        the number of observations.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     integer nv
!        the number of violations found.
!     integer nvmn
!        the smallest number of non-violations allowed.
!     integer nvmx
!        the largest number of violations allowed.
!     real vcmiss
!        missing value code in vec.
!     real vec(n)
!        the vector being tested.
!     real veclb
!        the value that the vector is being tested against.
!
  implicit none

  real &
     vcmiss,veclb
  integer &
     msgtyp,n,nv,nvmx
  logical &
     error,head
!
!  array arguments
  real &
     vec(*)
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i,nvmn
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  external subroutines
  external ervgtp

  error = .false.

  if (n <= 0) return
!
!  test whether testing is necessry
!
  if ((mod(msgtyp,3) == 0) .and. (vec(1) <= veclb)) return
!
!  check for violations
!
  nv = 0
  do i = 1, n
    if ( .not. mvchk ( vec(i), vcmiss) ) then
      if ( vec(i) <= veclb ) then
        nv = nv + 1
      end if
    end if
  end do

  if ( nv <= nvmx ) then
    return
  end if
!
!  violations found
!
  error = .true.
  nvmn = n - nvmx
  call ervgtp (nmsub, nmvar, veclb, nvmn, nvmx, head, msgtyp, nv, &
     nmmin)

  return
end
subroutine ervgtp ( nmsub, nmvar, veclb, nvmn, nvmx, head, msgtyp, nv, nmmin )

!*****************************************************************************80
!
!! ERVGTP prints the error messages for ERVGT and ERVGTM.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical head
!        a flag indicating whether the heading should be printed (true)
!        or not (false).
!     integer i
!        an index argument.
!     integer msgtyp
!        the indicator argument for the type of message.
!        if (msgtyp >= 4) the message printed will use nmmin
!        otherwise it will use veclb.
!        if (msgtyp = 1 or 4) no violations are allowed.
!        if (msgtyp = 2 or 5) the number of violations must
!                             be less than   nvmx   .
!        if (msgtyp = 3 or 6) violations are counted only if the
!                             the first element is not in violation.
!     character*1 nmmin(8)
!        the name of the argument specifying the minimum.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the arguments name.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!     real veclb
!        the value that the vector is being tested against.
!
  implicit none

  real &
     veclb
  integer &
     msgtyp,nv,nvmn,nvmx
  logical &
     head
!
!  array arguments
  character &
     nmmin(8)*1,nmsub(6)*1,nmvar(8)*1

  integer &
     i
!
!  external subroutines
  external ehdr

  call ehdr(nmsub, head)

  if (msgtyp <= 3) then
    write ( *, 1000) (nmvar(i),i=1,6), veclb, nv
  else
    if (msgtyp >= 7) then
      write ( *, 1001) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv
    else
      write ( *, 1002) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv
    end if
  end if

  if ( msgtyp == 1 ) then
    write ( *, 1010) (nmvar(i),i=1,6), veclb
  else if ( msgtyp == 2 ) then
    write ( *, 1020) (nmvar(i),i=1,3), veclb, nvmx
  else if ( msgtyp == 3 ) then
    write ( *, 1030) (nmvar(i),i=1,6), veclb, veclb
  else if ( msgtyp == 4 ) then
    write ( *, 1040) (nmvar(i),i=1,6), (nmmin(i),i=1,8)
  else if ( msgtyp == 5 ) then
    write ( *, 1050) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nvmx
  else if ( msgtyp == 6 ) then
    write ( *, 1060) (nmvar(i),i=1,6), (nmmin(i),i=1,8), &
     (nmmin(i),i=1,8)
  else if ( msgtyp == 7 ) then
    write ( *, 1070) nvmn, (nmvar(i),i=1,6), (nmmin(i),i=1,8)
  end if

  return

 1000 format (/ &
     ' the number of values in vector ', 6a1, &
     ' less than or equal to ', 1pe14.7, ' is ', i6, '.')
 1001 format (/ &
     ' the number of values in vector ', 6a1, &
    ' greater than ', 8a1, ' is ', i2, '.')
 1002 format (/ &
     ' the number of values in vector ', 6a1, &
     ' less than or equal to ', 8a1, ' is ', i6, '.')
 1010 format( &
     ' the values in the vector ', 6a1, &
     ' must all be greater than ', 1pe14.7, '.')
 1020 format( &
     ' the number of values in the vector ', 6a1, &
     ' less than or equal to ', 1pe14.7/ &
     ' must be less than ', i5, '.')
 1030 format( &
     ' since the first value of the vector ', 6a1, &
     ' is greater than ', 1pe14.7/ &
     ' all of the values must be greater than ', 1pe14.7, '.')
 1040 format( &
     ' the values in the vector ', 6a1, &
     ' must all be greater than ', 8a1, '.')
 1050 format( &
     ' the number of values in the vector ', 6a1, &
     ' less than or equal to ', 8a1/ &
     ' must be less than ', i5, '.')
 1060 format( &
     ' since the first value of the vector ', 6a1, &
     ' is greater than ', 8a1/ &
     ' 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, '.')
end
subroutine ervii ( nmsub, nmvar, y, n, ylb, yub, nvmx, head, msgtyp, &
  nv, error )

!*****************************************************************************80
!
!! ERVII checks for vector values outside given limits.
!
!  Discussion:
!
!    This routine checks for values in the input vector   y
!    which are outside the (inclusive) limits ylb to yub, prints
!    an error message if the number of violations exceeds the largest
!    number of violations allowed, and returns the number of
!    violations and an error flag indicating the results.  three
!    messages are available, specified by    msgtyp   .
!        if (msgtyp = 0) no violations are allowed.
!        if (msgtyp = 1) the number of violations must
!                        be less than   nvmx   .
!        if (msgtyp = 2) violations are counted only if the
!                        the first element is not in violation.
!
!  Modified:
!
!    28 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error
!        the value returned from the error checking routines to indicate
!        whether an error was detected (true) or not (false).
!     logical head
!        a flag indicating whether the heading should be printed (true)
!        or not (false).
!     integer i
!        an index variable.
!     integer msgtyp
!        the indicator variable for the type of message.
!        if (msgtyp = 0) no violations are allowed.
!        if (msgtyp = 1) the number of violations must
!                        be less than   nvmx   .
!        if (msgtyp = 2) violations are counted only if the
!                        the first element is not in violation.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar(8)
!        the characters of the parameters name.
!     integer nnv
!        the number of values not in violation.
!     integer nnvmn
!        the smallest number of values not in violation allowed.
!     integer nv
!        the number of violations found.
!     integer nvmx
!        the largest number of violations allowed.
!     real y(n)
!        the vector being tested.
!     real ylb, yub
!        the (inclusive) range that the vector is being tested
!        against.
!
  implicit none

  real &
     ylb,yub
  integer &
     msgtyp,n,nv,nvmx
  logical &
     error,head
!
!  array arguments
  real &
     y(*)
  character &
     nmsub(6)*1,nmvar(8)*1
!
!
  integer &
     i,nnv,nnvmn
!
!  external subroutines
  external ehdr

  error = .false.

  if (n <= 0) then
    return
  end if
!
!  test whether testing is necessry
!
  if ((msgtyp == 2) .and. &
      (y(1) < ylb) .or. (y(1) > yub)) return
!
!  check for violations
!
  nv = 0
  do i = 1, n
     if ((y(i)<ylb) .or. (y(i) > yub)) nv = nv + 1
  end do

  if (nv <= nvmx) return
!
!  violations found
!
  error = .true.

  call ehdr(nmsub, head)

  nnv = n - nv
  nnvmn = n - nvmx

  if (msgtyp == 0) then
     write ( *, 1010) (nmvar(i), i = 1, 6), ylb, yub, nv
  else if (msgtyp == 1) then
     write ( *, 1020) (nmvar(i), i = 1, 6), ylb, yub, &
     nnvmn, nnv
  else if (msgtyp == 2) then
     write ( *, 1030) (nmvar(i), i = 1, 6), ylb, yub
  end if

  return

 1010 format(/ &
     ' the values in the vector ', 6a1, &
     ' must all be in the range ', 1pe14.7, ' to'/ &
     1x, 1pe14.7, &
        ', inclusive. the number of values outside this range', &
     ' is ', i5, '.')
 1020 format(/ &
     ' the number of values in the vector ', 6a1, &
     ' in the range ', 1pe14.7, ' to'/ &
     1x, 1pe14.7, ', inclusive, must equal or exceed ', i5, '.'/ &
     ' the number of values in this range is ', i5, '.')
 1030 format(/ &
     ' if the first value of the vector ', 6a1, &
     ' is in the range', 1pe14.7, ' to'/ &
     1x, 1pe14.7, &
        ' inclusive, all of the values must be in this range.')
end
subroutine ervwt ( nmsub, nmvar1, wt, n, nnzwmn, head, nnzw, &
     nzw, msgtyp, error, nmvar2 )

!*****************************************************************************80
!
!! ERVWT checks user-supplied weights.
!
!  Discussion:
!
!    This routine checks user supplied weights to assure there
!    are no negative weights, and that there are sufficient positive
!    weights for the task.  it returns error set to true
!    if no errors are found, and set to false otherwise, and in
!    addition, returns the number of nonzero weights and the number
!    of zero weights.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index argument.
!     integer msgtyp
!        an argument used to indicate the type of message to be
!        printed, where if error is true and
!        msgtyp = 1, the input value was too small based on limits
!                    imposed by starpac.
!        msgtyp = 2, the input value was too small based on other
!                    input arguments.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the characters of the calling subroutines name.
!     character*1 nmvar1(8)
!        the characters of the name of the argument being checked.
!     character*1 nmvar2(8)
!        the characters of the name of the argument being checked
!        against.
!     integer nnzw
!        the number of nonzero weights.
!     integer nnzwmn
!        the minimum number of nonzero weights which is acceptable.
!     integer nzw
!        the number of zero weights.
!     real wt(n)
!        the weight vector.
!
  implicit none

  logical error
  logical head
  integer i
  integer j
  integer msgtyp
  integer n
  integer nnzw
  integer nnzwmn
  integer nzw

  real &
     wt(*)
  character &
     nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1


  error = .false.

  if (n <= 0) return
!
!  check for negative weights and count number of zero weights.
!
  nzw = 0

  do i = 1, n

    if (wt(i) < 0.0e0) then
      error = .true.
      call ehdr(nmsub, head)
      write ( *, 1020) (nmvar1(j), j = 1, 6)
      return
    end if

    if (wt(i) == 0.0e0) nzw = nzw + 1

  end do

  nnzw = n - nzw

  if (nnzw  >=  nnzwmn) return
!
!  insufficient number of positive weights found
!
  error = .true.

  call ehdr(nmsub, head)

  write ( *, 1010) nnzw

  if (msgtyp == 1) write ( *, 1030) (nmvar1(i), i=1,6), nnzwmn

  if (msgtyp == 2) write ( *,1040) (nmvar1(i),i=1,6), &
     (nmvar2(i),i=1,8)

  return

 1010 format(/ &
     ' the number of nonzero weights found is ', i6, '.')
 1020 format(/ &
     ' negative values were found in the vector ', 6a1, '.'/ &
     ' all weights must be greater than or equal to zero.')
 1030 format( &
     ' the number of nonzero weights in ', 6a1, &
     ' must be greater than or equal to ', i6, '.')
 1040 format( &
     ' the number of nonzero weights in ', 6a1, &
     ' must be greater than or equal to ', 8a1, '.')
end
subroutine etamdl ( mdl, par, npar, xm, n, m, ixm, eta, neta, &
     partmp, pv, nrowin )

!*****************************************************************************80
!
!! ETAMDL computes noise and number of good digits in model routine results.
!
!  Discussion:
!
!    This routine computes the noise and number of good digits in
!    results of model routine at row <nrow>.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real a, b
!        parameters of the fit.
!     real eta
!        the noise in the model results.
!     real fac
!        a factor used in the computations.
!     real fplrs
!        the floating point largest relative spacing.
!     integer i
!        an indexing variable.
!     integer ixm
!        actual first dimension of xm
!     real j
!        the value real ( i-3 ).
!     integer k
!        an index variable.
!     integer m
!        number of variables
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        number of observations
!     integer neta
!        the number of accurate digits in the model results.
!     integer npar
!        number of parameters
!     integer nrow
!        the row number actually used.
!     integer nrowin
!        the input number of the row being checked.
!     real par(npar)
!        model parameters
!     real partmp(npar)
!        modified model parameters
!     real pv(n)
!        predicted values
!     real rss(5)
!        the residual sum of squares for each value of j.
!     real rsssm
!        the sum of the residual sum of squares for each set of
!        parameter values.
!     real rsssmj
!        the sum of the residual sum of squares times j for each
!        set of parameter values.
!     real sqrtmp
!        the square root of machine precision (fplrs).
!     real xm(ixm,m)
!        independent variables
!
  implicit none

  real &
     eta
  integer &
     ixm,m,n,neta,npar,nrowin
!
!  array arguments
  real &
     par(npar),partmp(npar),pv(n),xm(ixm,m)
!
!  subroutine arguments
  external mdl
!
!
  real &
     a,b,fac,fplrs,rsssm,rsssmj,sqrtmp
  integer &
     i,k,nrow
!
!  local arrays
  real &
     rss(5)
!
!  external subroutines
  external setrow

  fplrs = epsilon ( fplrs )
!
!  select first row of independent variables which contains no zeros
!
  call setrow(nrowin, xm, n, m, ixm, nrow)

  sqrtmp = sqrt(fplrs)
  rsssm = 0.0e0
  rsssmj = 0.0e0

  do i=1,5

     do k=1,npar
        partmp(k) = par(k)*(1.0e0+ real ( i - 3 ) *sqrtmp)
     end do

     call mdl(partmp, npar, xm, n, m, ixm, pv)

     rss(i) = pv(nrow)

     rsssm = rsssm + rss(i)
     rsssmj = rsssmj + real ( i - 3 ) *rss(i)

  end do

  a = 0.2e00*rsssm
  b = 0.1e00*rsssmj
  fac = 1.0e0
  if (rss(3) /= 0.0e0) fac = fac/rss(3)

  do i=1,5
     rss(i) = abs((rss(i)-(a+ real ( i - 3 ) *b))*fac)
  end do

  eta = max(rss(1),rss(2),rss(3),rss(4),rss(5),fplrs)
  neta = - int ( log10 ( eta ) )
  eta = 10.0e0**(-neta)

  return
end
function extend ( x, i, n, sym )

!*****************************************************************************80
!
!! EXTEND returns the I-th term in a series.
!
!  Discussion:
!
!    This routine returns the I-th term in the series x,
!    extending if necessary with even or odd symmetry according
!    to the sign of sym, which should be either plus or minus one.
!    (the value zero will result in the extended value being zero.)
!    this routine is taken from bloomfields book, page 179.
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
  implicit none

  integer n

  real con
  real extend
  integer i
  integer j
  real sym
  real x(n)

  j = i
  con = 1.0e0

  do

    if ( j < 1 ) then
      j = 2-j
      con = con * sym
    end if

    if ( j <= n ) then
      exit
    end if

    j = 2*n-j
    con = con * sym

  end do

  extend = x(j) * con

  return
end
subroutine factor ( n, npf, ipf, ipfexp )

!*****************************************************************************80
!
!! FACTOR factors an integer.
!
!  Discussion:
!
!    This routine factors an input integer   n   and returns
!    the number of prime factors in   npf   , the value of the
!    prime factors in the vector   ipf   , and the exponent
!    of each of the prime factors in the vector   ipfexp   .
!    the elements of    ipf   are stored in increasing order.
!    the length of the vectors is sufficient to accomodate
!    the prime factors of an integer up to 2 ** 128 (approximately
!    10 ** 40).
!
!    This routine is adapted from the factoring routine given
!    in acm algorithm 467 (cacm, 1973, vol. 16, no. 11, page 692-694).
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer idiv, ifcur
!        various variables used to factor    n   .
!     integer ipf(50), ipfexp(50)
!        the vectors of prime factors of   n   , and their exponents,
!        respectively.
!     integer iquot
!        a variable used to factor   n   .
!     integer n
!        the value to be factored.
!     integer npart
!        a variable used to factor   n   .
!     integer npf
!        the number of factors found in    n   .
!
  implicit none

  integer &
     n,npf
!
!  array arguments
  integer &
     ipf(50),ipfexp(50)

  integer &
     idiv,ifcur,iquot,npart

  npf = 0
  ifcur = 0
  npart = n
  idiv = 2

  do

    iquot = npart/idiv

    if ( npart /= idiv*iquot ) then

      if (iquot <= idiv) then
        exit
      end if

      if (idiv < 3) then
        idiv = 3
      else
        idiv = idiv + 2
      end if

    else

      if (idiv <= ifcur) then
        ipfexp(npf) = ipfexp(npf) + 1
      else
        npf = npf + 1
        ipf(npf) = idiv
        ifcur = idiv
        ipfexp(npf) = 1
      end if

      npart = iquot

    end if

  end do

  if ( npart <= 1 ) then

    return

  else if ( npart <= ifcur ) then

    ipfexp(npf) = ipfexp(npf) + 1

  else

    npf = npf + 1
    ipf(npf) = npart
    ipfexp(npf) = 1

  end if

  return
end
subroutine fdump ( )

!*****************************************************************************80
!
!! FDUMP produces a symbolic dump.
!
!  Discussion:
!
!    This routine is intended to be replaced by a locally written
!    version which produces a symbolic dump.  Failing this,
!    it should be replaced by a version which prints the
!    subprogram nesting list.  
!
!    Normally, the dump information should be printed to all the
!    active error output units.  The number and value of these
!    units can be determined by calling XGETUA.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    None
!
  implicit none

  return
end
subroutine fftct ( x, n2, ix )

!*****************************************************************************80
!
!! FFTCT does a cosine transform of n=2*n2 symmetric data points.
!
!  Modified:
!
!    29 April 2006
!
!  Parameters:
!
!     integer ix
!        the dimension of x.
!     integer n2
!        the half length of the symmetric data array.  n2 must be even.
!     real x(ix)
!        the n2+2 vector with first half of symmetric data stored in
!        the first n2+1 locations.  location n2+2 used only for
!        workspace.  the cosine transform coefficients are returned
!        in the first n2+1 locations of x.
!
  implicit none

  integer &
     ix,n2

  real &
     x(ix)

  real &
     a2,aa,ab,cd,cn,ex,pi,save,sd,sn
  integer &
     i,isn,j,k,m,m1,n1,nk

  call getpi(pi)

  a2 = 0.0e0
  n1 = n2 + 1
  do j=2,n2,2
     a2 = a2 + x(j)
  end do
  a2 = 2.0e0*a2
  m = n2/2
  m1 = m + 1
  ex = x(2)
  x(2) = 0.0e0

  do i = 4, n1, 2
     save = ex - x(i)
     ex = x(i)
     x(i) = save
  end do

  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 / real ( 2 * n2 )
  cd = 2.0e0*sin(sd)**2
  sd = sin(sd+sd)
  sn = 0.0e0
  cn = 1.0e0
  nk = n2 + 2
  do 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
  end do

  ex = x(1)
  x(1) = ex + a2
  x(n2+1) = ex - a2
  x(n2+2) = 0.0e0

  return
end
subroutine fft ( a, b, ntot, n, nspan, isn )

!*****************************************************************************80
!
!! FFT is a multivariate complex Fourier transform.
!
!  Discussion:
!
!    This routine implements a multivariate complex Fourier transform, 
!    computed in place using mixed-radix fast Fourier transform algorithm.
!    by r. c. singleton, stanford research institute, oct. 1968
!
!    a tri-variate transform with a(n1,n2,n3), b(n1,n2,n3)
!    is computed by
!      call fft(a,b,n1*n2*n3,n1,n1,1)
!      call fft(a,b,n1*n2*n3,n2,n1*n2,1)
!      call fft(a,b,n1*n2*n3,n3,n1*n2*n3,1)
!    for a single-variate transform,
!    ntot = n = nspan = (number of complex data values), f.g.
!      call fft(a,b,n,n,n,1)
!    the data may alternatively be stored in a single complex
!    array a, then the magnitude of isn changed to two to
!    give the correct indexing increment and a(2) used to
!    pass the initial address for the sequence of imaginary
!    values, e.g.
!      call fft(a,a(2),ntot,n,nspan,2)
!    arrays at(maxf), ck(maxf), bt(maxf), sk(maxf), and np(maxp)
!    are used for temporary storage.  if the availabel storage
!    is insufficient, the program is terminated by a stop.
!    maxf must be  >=  the maximum prime factor of n.
!    maxp must be > the number of prime factors of n.
!
!     nb. the above description of maxp appears to be incorrect.
!         maxp seems to be the maximum size of the square free
!         portion k of n.
!
!    in addition, if the square-free portion k of n has two or
!    more prime factors, then maxp must be  >=  k-1.
!     dimension a(1), b(1)
!    array storage in nfac for a maximum of 11 factors of n.
!    if n has more than one square-free factor, the product of the
!    square-free factors must be <= 210
!    dimension nfac(11), np(209)
!    array storage for maximum prime factor of 23
!    dimension at(23), ck(23), bt(23), sk(23)
!
!  Parameters:
!
!    arrays a and b originally hold the real and imaginary
!    components of the data, and return the real and
!    imaginary components of the resulting Fourier coefficients.
!    multivariate data is indexed according to the fortran
!    array element successor function, without limit
!    on the number of implied multiple subscripts.
!    the subroutine is called once for each variate.
!    the calls for a multivariate transform may be in any order.
!
!    ntot is the total number of complex data values.
!
!    n is the dimension of the current variable.
!
!    nspan/n is the spacing of consecutive data values
!    while indexing the current variable.
!
!    the sign of isn determines the sign of the complex
!    exponential, and the magnitude of isn is normally one.
!
  implicit none

  integer &
     maxf1
  parameter (maxf1=23)
  integer &
     maxp1
  parameter (maxp1=209)
!
!  scalar arguments
  integer &
     isn,n,nspan,ntot
!
!  array arguments
  real &
     a(*),b(*)
!
!
  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,j,jc,jf,jj,k,k1,k2,k3,k4,kk,ks,kspan,kspnn, &
     kt,m,maxf,maxp,nn,nt
!
!  local arrays
  real &
     at(maxf1),bt(maxf1),ck(maxf1),sk(maxf1)
  integer &
     nfac(11),np(maxp1)
!
!  equivalences
  equivalence (i,ii)
!
!  the following two constants should agree with the array dimensions.
!
  maxf = maxf1
  maxp = maxp1
  if (n<2) return
!
!  initialize variables
!
  c1 = 0
  c2 = 0
  c3 = 0
  s1 = 0
  s2 = 0
  s3 = 0
  k1 = 0
  k2 = 0
  k3 = 0
  k4 = 0

  inc = isn
  rad = 8.0e0*atan(1.0e0)
  s72 = rad/5.0e0
  c72 = cos(s72)
  s72 = sin(s72)
  s120 = sqrt(0.75e0)

  if ( isn < 0) then
    s72 = -s72
    s120 = -s120
    rad = -rad
    inc = -inc
  end if

  nt = inc*ntot
  ks = inc*nspan
  kspan = ks
  nn = nt - inc
  jc = ks/n
  radf = rad * real ( jc ) * 0.5e0
  i = 0
  jf = 0
!
!  determine the factors of n
!
  m = 0
  k = n

  do

    if ( k - ( k / 16 ) * 16 /= 0 ) then
      exit
    end if

    m = m + 1
    nfac(m) = 4
    k = k / 16

  end do

  j = 3
  jj = 9

  go to 50
   40 m = m + 1
  nfac(m) = j
  k = k/jj
   50 if (mod(k,jj) == 0) go to 40
  j = j + 2
  jj = j**2
  if (jj <= k) go to 50
  if (k > 4) go to 60

  if (k > 4) go to 60
  kt = m
  nfac(m+1) = k
  if (k /= 1) m = m + 1
  go to 100
   60 if (k-(k/4)*4 /= 0) go to 70
  m = m + 1
  nfac(m) = 2
  k = k/4
   70 kt = m
  j = 2
   80 if (mod(k,j) /= 0) go to 90
  m = m + 1
  nfac(m) = j
  k = k/j
   90 j = ((j+1)/2)*2 + 1
  if (j <= k) go to 80
  100 if (kt == 0) go to 120
  j = kt
  110 m = m + 1
  nfac(m) = nfac(j)
  j = j - 1
  if (j /= 0) go to 110
!
!  compute Fourier transform
!
  120 sd = radf / real ( kspan )
  cd = 2.0e0*sin(sd)**2
  sd = sin(sd+sd)
  kk = 1
  i = i + 1
  if (nfac(i) /= 2) go to 170
!
!  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 <= nn) go to 130
  kk = kk - nn
  if (kk <= jc) go to 130
  if (kk > 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<nt) go to 150
  k2 = kk - nt
  c1 = -c1
  kk = k1 - k2
  if (kk > k2) go to 150
  ak = c1 - (cd*c1+sd*s1)
  s1 = (sd*c1-cd*s1) + s1
!
!  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<k2) go to 150
  k1 = k1 + inc + inc
  kk = (k1-kspan)/2 + jc
  if (kk <= jc+jc) go to 140
  go to 120
!
!  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<nn) go to 160
  kk = kk - nn
  if (kk <= kspan) go to 160
  go to 320
!
!  transform for factor of 4
!
  170 if (nfac(i) /= 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<0) go to 220
  akp = akm - bjm
  akm = akm + bjm
  bkp = bkm + ajm
  bkm = bkm - ajm
  if (s1 == 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 <= 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 <= kspan) go to 190
  kk = kk - kspan + inc
  if (kk <= jc) go to 180
  if (kspan == jc) go to 360
  go to 120
  220 akp = akm + bjm
  akm = akm - bjm
  bkp = bkm - ajm
  bkm = bkm + ajm
  if (s1 /= 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 <= nt) go to 190
  go to 210
!
!  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<nn) go to 250
  kk = kk - nn
  if (kk <= kspan) go to 250
  go to 320
!
!  transform for odd factors
!
  260 k = nfac(i)
  kspnn = kspan
  kspan = kspan/k
  if (k == 3) go to 160
  if (k == 5) go to 240
  if (k == jf) go to 280
  jf = k
  s1 = rad / real ( k )
  c1 = cos(s1)
  s1 = sin(s1)
  if (jf > 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<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<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 > jf) jj = jj - jf
  if (k<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<k) go to 300
  kk = kk + kspnn
  if (kk <= nn) go to 280
  kk = kk - nn
  if (kk <= kspan) go to 280
!
!  multiply by rotation factor (except for factors of 2 and 4)
!
  320 if (i == 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 <= nt) go to 350
  ak = s1*s2
  s2 = s1*c2 + c1*s2
  c2 = c1*c2 - ak
  kk = kk - nt + kspan
  if (kk <= 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 <= kspan) go to 340
  kk = kk - kspan + jc + inc
  if (kk <= jc+jc) go to 330
  go to 120
!
!  permute the results to normal order--- done in two stages
!  permutation for square factors of n
!
  360 np(1) = ks
  if (kt == 0) go to 450
  k = kt + kt + 1
  if (m<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<k) go to 370
  k3 = np(k+1)
  kspan = np(2)
  kk = jc + 1
  k2 = kspan + 1
  j = 1
  if (n /= ntot) go to 410
!
!  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<ks) go to 380
  390 k2 = k2 - np(j)
  j = j + 1
  k2 = np(j+1) + k2
  if (k2 > np(j)) go to 390
  j = 1
  400 if (kk<k2) go to 380
  kk = kk + inc
  k2 = kspan + k2
  if (k2<ks) go to 400
  if (kk<ks) go to 390
  jc = k3
  go to 450
!
!  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<k) go to 420
  kk = kk + ks - jc
  k2 = k2 + ks - jc
  if (kk<nt) go to 410
  k2 = k2 - nt + kspan
  kk = kk - nt + jc
  if (k2<ks) go to 410
  430 k2 = k2 - np(j)
  j = j + 1
  k2 = np(j+1) + k2
  if (k2 > np(j)) go to 430
  j = 1
  440 if (kk<k2) go to 410
  kk = kk + jc
  k2 = kspan + k2
  if (k2<ks) go to 440
  if (kk<ks) go to 430
  jc = k3
  450 if (2*kt+1 >= m) return
  kspnn = np(kt+1)
!
!  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 /= kt) go to 460
  kt = kt + 1
  nn = nfac(kt) - 1
  if (nn > 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 >= k2) go to 470
  np(j) = jj
  490 k2 = nfac(kt)
  k = kt + 1
  kk = nfac(k)
  j = j + 1
  if (j <= nn) go to 480
!
!  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 /= j) go to 500
  k3 = kk
  510 j = j + 1
  kk = np(j)
  if (kk<0) go to 510
  if (kk /= j) go to 500
  np(j) = -j
  if (j /= nn) go to 510
  maxf = inc*maxf
!
!  reorder a and b, following the permutation cycles
!
  go to 580
  520 j = j - 1
  if (np(j)<0) go to 520
  jj = jc
  530 kspan = jj
  if (jj > 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 /= 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 /= kk) go to 560
  kk = k2
  if (k /= 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 /= kk) go to 570
  if (jj /= 0) go to 530
  if (j /= 1) go to 520
  580 j = k3 + 1
  nt = nt - kspnn
  ii = nt - inc + 1
  if (nt >= 0) go to 520
  return
!
!  error finish, insufficient array storage
!
  590 isn = 0
  write ( *, 1000)
!
!  the following stop should be changed to a return when
!  the time series routines are modified for starpac.
!
  stop

 1000 format (' ', 17('*')/' * error message *'/1x, 17('*')// &
     ' array bounds exceeded within subroutine fft.'/ &
     ' please bring this error to the attention of'/ &
     '    janet r. donaldson'/ &
     '    303-497-5114'/ &
     '    fts 320-5114')
end
subroutine fftlen ( n, ndiv, nfft )

!*****************************************************************************80
!
!! FFTLEN computes the value of NFFT for the Singleton FFT routine.
!
!  Discussion:
!
!    This routine computes the smallest value of nfft which
!    equals or exceeds n + 2, such that nfft - 2 is divisible by
!    ndiv and has no prime factors greater than 23, and the
!    product of the non square prime factors of nfft - 2 do not
!    exceed 209.  the value of nfft thus meet the requirements of
!    the extended length of the series required for any routine
!    using the singleton fft providing the proper value of ndiv
!    is chosen.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,ndiv,nfft
!
!  scalars in common
  integer &
     ierr

  logical &
     err01,err02,head
!
!  local arrays
  character &
     ln(8)*1,lndiv(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,setesl
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01, err02
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     character*1 ln(8), lndiv(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer n
!        the number upon which nfft is based.
!     integer ndiv
!        a required factor of nfft - 2.
!     integer nfft
!        the returned value which meets the above description.
!     character*1 nmsub(6)
!        the name of the routine calling the error checking
!        subroutine.
!
!     set up name arrays
!
  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) &
   /     ' ',       ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 1, 1, head, err01, ln)

  call eisge(nmsub, lndiv, ndiv, 1, 1, head, err02, lndiv)

  if ( err01 .or. err02 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call setesl(n, ndiv, nfft)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call fftlen (n, ndiv, nfft)')

end
subroutine fftr ( yfft, n, nfft, iextnd, nf, ab, lab )

!*****************************************************************************80
!
!! FFTR is the user-callable routine for the Fourier transform of a series.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer ierr
  integer iextnd
  integer lab
  integer n
  integer nf
  integer nfft
!
!  array arguments
  real &
     ab(*),yfft(*)

  real &
     yextnd
  integer isn,nfft1,nfft2
  logical &
     err01,err02,err03,head
!
!  local arrays
  character &
     llab(8)*1,ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external amean,eisge,fft,realtr
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real ab(lab)
!        the vector of the nf real and imaginary components of the
!        Fourier coefficients.
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer i
!        an index variable.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer iextnd
!        the indicator variable used to designate whether zero
!        (iextnd == 0) or the series mean (iextnd  /=  0) is to be
!        used to extend the series.
!     integer lab
!        the length of the vector ab.
!     character*1 llab(8), ln(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer n
!        the integer number of observations.
!     integer n1
!        the value n+1.
!     integer nf
!        the number of frequencies at which the periodgram is
!        to be computed.
!     integer nfft
!        the effective length of the series to be transformed.
!     integer nfft1
!        the effective series length actually used.
!     integer nfft2
!        the effective length of the series stored as a complex
!        variable.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     real yextnd
!        the value used to extend the series.
!     real yfft(n)
!        the array containing the observed time series.
!
!     set up name arrays
!
  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) &
   /     ' ',       ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  if (err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call enfft ( nmsub, nfft, 2, n, lab, nfft1, head, err02 )

  nf = nfft1/2

  call eisge ( nmsub, llab, lab, nfft1, 9, head, err03, llab )

  if (err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  Copy the input series to ab, extending appropriately.
!
  yextnd = 0.0e0
  if (iextnd  /=  0) call amean (yfft, n, yextnd)

  ab(1:n) = yfft(1:n)

  ab(n+1:nfft1) = yextnd

  nfft2 = (nfft1-2) / 2
  isn = 2

  call fft (ab(1), ab(2), nfft2, nfft2, nfft2, isn)
  call realtr (ab(1), ab(2), nfft2, isn)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call fftr (yfft, n, nfft, iextnd, nf, ab, lab)')
end
subroutine fitext ( rss, yss, exact )

!*****************************************************************************80
!
!! FITEXT checks whether the fit is exact to machine precision.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical exact
!        an indicator value used to designate whether the fit
!        was exact to machine precision (true) or not (false).
!     real fplrs
!        the floating point largest relative spacing.
!     real rss
!        the residual sum of squares.
!     real rsstst
!        the value for testing whether the residual sum of squares
!        is zero (to within machine precision).
!     real yss
!        the sum of squares of the dependent variable y.
!
  implicit none

  real &
     rss,yss
  logical &
     exact

  real &
     fplrs,rsstst

  fplrs = epsilon ( fplrs )
!
!  test for exact fit
!
  exact = .false.
  rsstst = rss
  if (yss > 0.0e0) rsstst = rsstst / yss
  rsstst = sqrt(rsstst)
  if (rsstst<10.0e0*fplrs) exact = .true.

  return
end
subroutine fitpt1 ( n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, &
     nnzw, weight, iptout )

!*****************************************************************************80
!
!! FITPT1 prints the data summary for nonlinear least squares routines.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ierr
!        the integer value designating whether any errors have
!        been detected.
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected.
!     integer iptout
!        the variable used to control printed output.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer jcolm
!        the last column of the independent variable to be printed.
!     integer jcol1
!        the first column of the independent variable to be printed.
!     integer k
!        an index variable.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer nmax
!        the maximum number of rows to be printed.
!     integer nnzw
!        the number of non zero weights.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the user supplied weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
  implicit none

  integer &
     iptout,ixm,m,n,nnzw
  logical &
     weight
!
!  array arguments
  real &
     pv(n),res(n),sdpv(n),sdres(n),wt(n),xm(ixm,m),y(n)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,jcol1,jcolm,k,nmax
!
!  common blocks
  common /errchk/ierr


  write ( *,1100)

  if (weight) then
     write ( *,1010)
  else
     write ( *,1000)
  end if
  write ( *, 1110)
!
!  test whether column vector xm(*, 1) = vector 1.0e0
!
  do i=1,n
    if (xm(i,1) /= 1.0e0) go to 20
  end do
  go to 30
!
!  not a unit vector
!
   20 jcol1 = 1
  jcolm = min(m,3)
  go to 40
!
!  unit vector
!
   30 jcolm = min(m,4)
  jcol1 = min(2,jcolm)
   40 k = jcolm - jcol1 + 1

  nmax = n
  if ((iptout == 1) .and. (n >= 45)) nmax = min(n,40)
!
!  print observation summary
!
  call obssum(n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, &
     weight, k, 1, nmax, jcol1, jcolm)

  if ( nmax < n ) then

    do i = 1, 3

      if ( k == 1 ) then
        write ( *,1120)
      else if ( k == 2 ) then
        write ( *,1130)
      else if ( k == 3 ) then
        write ( *,1140)
      end if

      write ( *, 1150)
      if (weight) write ( *, 1160)

    end do
!
!  print last line of output
!
    call obssum(n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, &
      weight, k, n, n, jcol1, jcolm)

  end if

  if ((nnzw<n) .and. (ierr == 0)) write ( *, 1060)
  if ((nnzw<n) .and. (ierr == 4)) write ( *, 1070)
  if ((nnzw == n) .and. (ierr == 4)) write ( *, 1080)
  if ((ierr > 0) .and. (ierr /= 4)) write ( *, 1090)

  return

 1000 format (/53x, 'dependent', 7x, 'predicted', 5x, ' std dev of ', &
     24x, 'std '/ &
     2x, 'row', 13x, 'predictor values', 20x, 'variable', 8x, &
     ' value', 8x, 'pred value  ', 6x, 'residual ', 8x, 'res')
 1010 format (/53x, 'dependent', 7x, 'predicted', 5x, ' std dev of ', &
     24x, 'std '/ &
     2x, 'row', 13x, 'predictor values', 20x, 'variable', 8x, &
     ' value', 8x, 'pred value  ', 6x, 'residual ', 8x, 'res', &
     4x, 'weight')
 1060 format (// ' *  nc  -  value not computed because', &
     ' the weight is zero.')
 1070 format (// ' *  nc  -  value not computed because either', &
     ' the weight or the standard deviation of the residual', &
     ' is zero.')
 1080 format (// ' *  nc  -  value not computed because', &
     ' the standard deviation of the residual is zero.')
 1090 format (// ' *  nc  -  value not computed', &
     ' because convergence problems prevented the covariance', &
     ' matrix from being computed.')
 1100 format (//' 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
subroutine fitpt2 ( sdres, pv, wt, n, nnzw, weight, res, rss )

!*****************************************************************************80
!
!! FITPT2 prints the four standardized residual plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real annzw
!        the number of nonzero weights, used in computing
!        the normal probability plot.
!     real fac1, fac2
!        factors used in computing the normal probability plot.
!     real fplm
!        the floating point largest magnitude.
!     real gamma
!        a value used in computing the normal probability plot.
!     character*1 iblank
!        the value of the character -blank-.
!     integer ierr
!        the integer value designating whether any errors have
!        been detected.
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected.
!     integer ifirst
!        the first row of the variables to be plotted.
!     integer imid
!        the midpoint of the first plot of the second set
!     character*1 iminus
!        the character minus.
!     integer iplot
!        an indicator variable designating whether the first or
!        second set of two plots are being printed.
!     character*1 iplus
!        the character plus.
!     integer iprb
!        the location in the plot string of the symbol for the
!        probability plot.
!     integer ipv
!        the location in the plot string of the symbol for the plot
!        versus predicted value.
!     integer irow
!        the row of the variables being plotted.
!     character*1 istar
!        the character star.
!     integer ix
!        the location in the plot string of the symbol for the plots
!        versus the independent variable.
!     integer k, l
!        index variables.
!     character*1 line(102)
!        the symbols (blanks and characters) for a given line
!        of the plot.
!     integer n
!        the number of observations in each column of data.
!     integer ncol, ncolpl, ncolp1, ncolt2
!        the number of columns in the plot, ncol+l, ncol+1,
!        and ncol * 2.
!     integer nnzw
!        the number of non zero weights.
!     integer nrow
!        the number of columns in the plot.
!     real pi
!        the value of pi.
!     real pv(n)
!        the predicted value based on the current coefficient estimates
!     real pvdiv
!        the value of a division along the -predicted value- axis.
!     real pvmax
!        the largest value in the vector pv.
!     real pvmid
!        the midpoint of the range of values in the vector pv.
!     real pvmin
!        the smallest value in the vector pv.
!     real ratio
!        a value used to produce the normal probability plot.
!     real res(n)
!        the residuals from the fit.
!     real rowdiv
!        the value of a division along the -row- axis.
!     real rowmax
!        the largest row value.
!     real rowmid
!        the midpoint of the range of the rows plotted.
!     real rowmin
!        the smallest row value plotted.
!     real rss
!        the residual sum of squares.
!     real sdres(n)
!        the standard deviations of the residuals.
!     real w
!        the value of the weight for the current value being plotted.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the user supplied weights.
!     real ylabel
!        the label to be printed along the y axis.
!     real ymax
!        the largest value along the y axis
!     real ymin
!        the smallest value along the y axis.
!
  implicit none

  real &
     rss
  integer &
     n,nnzw
  logical &
     weight
!
!  array arguments
  real &
     pv(n),res(n),sdres(n),wt(n)
!
!  scalars in common
  integer &
     ierr

  real &
     annzw,dot,fac1,fac2,fplm,gamma,pi,pvdiv,pvmax,pvmid,pvmin, &
     ratio,rowdiv,rowmax,rowmid,rowmin,w
  real ylabel, &
     ymax,ymin
  integer &
     i,i1,i2,idot,ifirst,imid,iplot,iprb,ipv,irow,ix,k,l, &
     ncol,ncolp1,ncolpl,ncolt2,ndot,nrow
  character &
     iblank*1,iminus*1,iplus*1,istar*1
!
!  local arrays
  character &
     line(102)*1
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  common blocks
  common /errchk/ierr

  data iplus/'+'/, iminus/'-'/, istar/'*'/, iblank/' '/

  fplm = huge ( fplm )
!
!  check for insufficient points to plot
!
  if (ierr == 4) then
     do i = 1, n
        if (sdres(i) /= fplm) go to 5
     end do
     write ( *, 1090)
     return
  end if

    5 continue
!
!  initialize variables for probability plot
!
  call getpi(pi)
  gamma = pi/8.0e0
  annzw = real ( nnzw )
  fac1 = 1.0e0 / (annzw - 2.0e0*gamma + 1.0e0)
  fac2 = 10.0e0
!
!  initialize the plot size (in plot units)
!
  nrow = 26
  ncol = 51
  ncolp1 = ncol + 1
  ncolt2 = 2*ncol
  imid = (ncol-1)/2
!
!  find the first row of observations with nonzero weights
!
  ifirst = 1

  if ( weight ) then

    do i=1,n
      if ( 0.0E+00 < wt(i) ) then
        ifirst = i
        exit
      end if
    end do
  end if
!
!  begin computations for first set of plots
!
   iplot = 1
!
!  set x axis limits for standardized residual vs row plot,
!  and standardized residuals vs predicted values plot.
!
  rowmin = real ( ifirst )
  pvmin = pv(ifirst)
  pvmax = pv(ifirst)
  rowmax = real ( ifirst )
  do i=ifirst,n
     w = 1.0e0
     if (weight) w = wt(i)
     if (w > 0.0e0) then
        rowmax = real ( i )
        if (pv(i)<pvmin) pvmin = pv(i)
        if (pv(i) > pvmax) pvmax = pv(i)
     end if
  end do

  if ( pvmax <= pvmax ) then
    if (pvmin == 0.0e0) then
      pvmin = -0.5e0
      pvmax = 0.5e0
    else
      pvmin = pvmin - pvmin/2.0e0
      pvmax = pvmax + pvmax/2.0e0
    end if
  end if

  rowmid = (rowmax+rowmin)/2.0e0
  rowdiv = (rowmax-rowmin)/real ( ncol - 1 )
  pvmid = (pvmax+pvmin)/2.0e0
  pvdiv = (pvmax-pvmin)/ real ( ncol - 1 )
!
!  print titles for first plots
!
  write ( *,1000)
  go to 90
!
!  begin computations for second set of plots
!
   40 iplot = 2
!
!  print titles for second plots
!
  write ( *,1050)
!
!  write first line of plots
!
   90 continue
!
!  print plots, one line at a time
!
  ylabel = 3.75e0
  ymax = fplm
  ymin = 4.05e0

  do k=1,nrow

     ymin = ymin - 0.3e0
     if (-3.70e0 >= ymin) ymin = -fplm

     do l=1,ncol

        ncolpl = l + ncol
        line(l) = iblank
        line(ncolpl) = iblank

        if ((k /= 1) .and. (k /= nrow)) then
          cycle
        end if

           line(l) = iminus
           line(ncolpl) = iminus

           if ( mod(l,10) == 1 .or. l == 1+ncol/2 ) then
              line(l) = iplus
              line(ncolpl) = iplus
           end if

     end do

     do i=1,n

        if (weight) then
           w = wt(i)
        else
           w = 1.0e0
        end if
        if ((w /= 0.0e0) .and. (.not.mvchk(sdres(i),fplm))) then
           if ((sdres(i) > ymin) .and. (sdres(i) <= ymax)) then
              if (iplot == 1) then
!
!  set plot line for first set of plots
!
                 irow = int(((real( i ) -rowmin)/rowdiv)+1.5e0)
                 line(irow) = istar
                 ipv = int((pv(i)-pvmin)/pvdiv+1.5e0) + ncol
                 line(ipv) = istar
              else
!
!  set plot line for probability plot
!
                 ratio = (annzw-gamma) * fac1
                 iprb = int(4.91e0*(ratio**0.14e0- &
                           (1.0e0-ratio)**0.14e0)*fac2) + 77
                 if (iprb <= ncol) iprb = ncol+1
                 if (iprb >= 103) iprb = 102
                 line(iprb) = istar
                 annzw = annzw - 1.0e0
                 if ((annzw<2.0e0) .and. (nnzw <= 10)) then
                    gamma = 1.0e0/3.0e0
                 end if
              end if
           end if
        end if

     end do
!
!  set plot line for correlation plot
!
     if (iplot == 2) then
        if (k <= n-1) then
          dot = 0.0e0
          if (weight) then
            ndot = 0
            do idot = 1, n-k
              if ((wt(idot) > 0.0e0) .and. &
                  (wt(idot+k) > 0.0e0)) then
                ndot = ndot + 1
                dot = dot + res(idot)*res(idot+k)
              end if
            end do
            if (ndot >= 1) then
               dot = dot * real ( n - k ) / real ( ndot )
            end if
          else
            do idot = 1, n-k
              dot = dot + res(idot) * res(idot+k)
            end do
          end if
          ix = int ( real ( imid ) * dot / rss ) + imid + 1
          i1 = min(ix,imid+1)
          i2 = max(ix,imid+1)
          line(i1:i2) = istar
        end if
     end if

     if (mod(k,5) == 1) then
        if (iplot == 1) then
           write ( *,2020) ylabel, (line(l),l=1,ncol), ylabel, &
           (line(l),l=ncolp1,ncolt2)
        else
           write ( *,1020) k, (line(l),l=1,ncol), ylabel, &
           (line(l),l=ncolp1,ncolt2)
        end if
        ylabel = ylabel - 1.5
     else
        write ( *,1030) (line(l),l=1,102)
     end if

     ymax = ymin

  end do
!
!  print bottom line of graphs
!
  if (iplot == 1) then
!
!  print x axis labels for first set of plots
!
     write ( *,1040) rowmin, rowmid, rowmax, pvmin, pvmid, pvmax
     go to 40
  else
!
!  print x axis labels for second set of plots
!
     write ( *,1070)
  end if

  return

 1000 format (/20x, ' std res vs row number ', 35x, &
     ' std res vs predicted values' )
 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, ' normal probability plot of std res' )
 1070 format (4x, '-1.00', 22x, '0.0', 21x, '1.00', 5x, '-2.5', 23x, &
     '0.0', 22x, '2.5')
 1090 format (// 1x, 13('*')/ 1x, '*  warning  *'/ 1x, 13('*')// &
     ' the standardized residual plots have been suppressed.', &
     '  none of the standardized residuals could be', &
     ' computed,'/ &
     ' because for each observation either the weight or', &
     ' the standard deviation of the residual is zero.')
 2020 format (1x, f5.2, '+', 51a1, '+', 3x, f5.2, '+', 51a1, '+')
end
subroutine fitsxp ( par, pv, sdpv, res, sdres, vcv, n, npar, ivcv, rsd )

!*****************************************************************************80
!
!! FITSXP generates reporst for least squares exerciser returned storage.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     rsd
  integer &
     ivcv,n,npar
!
!  array arguments
  real &
     par(npar),pv(n),res(n),sdpv(n),sdres(n),vcv(ivcv,npar)

  integer &
     i
!
!  external subroutines
  external lstvec,matprt
!
!     variable definitions (alphabetically)
!
!     integer i
!        index variable
!     integer ivcv
!        actual first dimension of vcv
!     integer n
!        number of observations
!     integer npar
!        number of parameters
!     real par(npar)
!        the estimated parameters.
!     real pv(n)
!        predicted values
!     real res(n)
!        residuals
!     real rsd
!        residual standard deviation
!     real sdpv(n)
!        standard deviation of predicted values
!     real sdres(n)
!        standard deviation of residuals
!     real vcv(ivcv,npar)
!        variance covarance matrix
!
  write ( *,1000)
  write ( *,1002)
  call lstvec(npar, par)
  write ( *,1001)
  do i=1,n
     write ( *,1010) pv(i), sdpv(i), res(i), sdres(i)
  end do

  write ( *,1020)
  call matprt(vcv, vcv, npar, 1, 1, ivcv)
  write ( *,1030) rsd

  return

 1000 format(//' returned results from least squares fit'/ 1x, 39('-'))
 1001 format (//7x, 'pv', 13x, 'sdpv', 12x, 'res',12x, 'sdres')
 1002 format (//' parameters from fit')
 1010 format (1x, g14.7, 2x, g14.7, 2x, g14.7, 2x, g14.7)
 1020 format (//' variance covariance matrix')
 1030 format (//' rsd =', g14.7)
end
subroutine fitxsp ( par, pv, sdpv, res, sdres, vcv, n, npar, ivcv, &
     nnzw, npare, rsd )

!*****************************************************************************80
!
!! FITXSP generates reports for least squares exerciser returned storage.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     rsd
  integer &
     ivcv,n,nnzw,npar,npare
!
!  array arguments
  real &
     par(npar),pv(n),res(n),sdpv(n),sdres(n),vcv(ivcv,npar)

  integer &
     i
!
!  external subroutines
  external matprt
!
!     variable definitions (alphabetically)
!
!     integer ivcv
!        actual first dimension of vcv
!     integer n
!        number of observations
!     integer npar
!        number of parameters
!     integer npare
!        number of parameters estimated by routine.
!     integer nnzw
!        number of nonzero weights.
!     real par(npar)
!        the estimated parameters.
!     real pv(n)
!        predicted values
!     real res(n)
!        residuals
!     real rsd
!        residual standard deviation
!     real sdpv(n)
!        standard deviation of predicted values
!     real sdres(n)
!        standardized residuals.
!     real vcv(ivcv,npar)
!        variance covarance matrix
!
  write ( *,1000)

  do i=1,n
     if (i <= npar) then
        write ( *,1010) i,par(i),res(i),pv(i),sdpv(i),sdres(i)
     else
        write ( *,1070) i,res(i),pv(i),sdpv(i),sdres(i)
     end if
  end do

  write ( *,1030)
  call matprt(vcv, vcv, ivcv, 1, 1, ivcv)
  write ( *,1060) rsd
  write ( *,1040) nnzw
  write ( *,1050) npare

  return

 1000 format (/12x, 'par', 12x, 'res', 12x, 'pv', 13x, 'sdpv', 12x, &
     'sdres'/)
 1010 format (1x, i5, g14.7, 2x, 4(g14.7, 2x))
 1030 format (/' variance covariance matrix')
 1040 format (' nnzw = ', i5)
 1050 format (' npare = ', i5)
 1060 format (/' rsd = ', g14.7)
 1070 format (1x, i5, 16x, 4(g14.7, 2x))
end
subroutine fixprt ( ifix, fixed )

!*****************************************************************************80
!
!! FIXPRT sets the character array 'FIXED'.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     character*1 fixed(3)
!        the characters used to label the parameters fixed or not.
!     integer i
!        an index variable.
!     integer ifix
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifix == 0, then fixed will be set to no.
!        if ifix /= 0, then fixed will be set to yes.
!     character*1 no(3)
!        the characters blank, n, and o
!     character*1 yes(3)
!        the characters y, e, and s
!
  implicit none

  integer &
     ifix
!
!  array arguments
  character &
     fixed(3)*1

!
!  local arrays
  character &
     no(3)*1,yes(3)*1

  data no(1)/' '/, no(2)/'n'/, no(3)/'o'/
  data yes(1)/'y'/, yes(2)/'e'/, yes(3)/'s'/

  if (ifix /= 0) then
    fixed(1:3) = yes(1:3)
  else
    fixed(1:3) = no(1:3)
  end if

  return
end
subroutine fltar ( y, n, iar, phi, yf, nyf )

!*****************************************************************************80
!
!! FLTAR filters an input series using an autoregressive filter.
!
!  Discussion:
!
!    This routine filters the input series y using the iar terms
!    of the autoregressive filter phi, copying the filtered series
!    into yf.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iar,n,nyf
!
!  array arguments
  real &
     phi(*),y(*),yf(*)

  real &
     temp
  integer &
     i,i1,j,k
!
!     variable definitions (alphabetically)
!
!     integer i
!        an indexing variable.
!     integer iar
!        the number of filter terms.
!     integer i1, j, k
!        indexing variables.
!     integer n
!        the number of observations in the series y.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real phi(iar)
!        the array in which the filter coefficients are stored.
!     real temp
!        a temporary storage location.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  yf(1:n) = y(1:n)

  nyf = n - iar

  do i = 1, nyf
     k = i + iar
     temp = yf(k)
     do j = 1, iar
        k = k - 1
        temp = temp - phi(j) * yf(k)
     end do
     yf(i) = temp
  end do

  i1 = nyf + 1

  yf(i1:n) = 0.0e0

  return
end
subroutine fltarm ( y, ymiss, n, iar, phi, yf, yfmiss, nyf )

!*****************************************************************************80
!
!! FLTARM filters a series with missing data, using an autoregressive filter.
!
!  Discussion:
!
!    This routine filters the input series y, which contains missing
!    data, using the iar terms of the autoregressive filter phi,
!    copying the filtered series into yf.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     yfmiss,ymiss
  integer &
     iar,n,nyf
!
!  array arguments
  real &
     phi(*),y(*),yf(*)

  real &
     fplm,temp
  integer &
     i,i1,j,k
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!     variable definitions (alphabetically)
!
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an indexing variable.
!     integer iar
!        the number of filter terms.
!     integer i1, j, k
!        indexing variables.
!     integer n
!        the number of observations in the series y.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real phi(iar)
!        the array in which the filter coefficients are stored.
!     real temp
!        a temporary storage location.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!     real yfmiss
!        the missing value code used in the filtered series to
!        indicate the value could not be computed due to missing data.
!     real ymiss
!        the missing value code used in the input series to indicate
!        an observation is missing.
!
  fplm = huge ( fplm )

  yfmiss = fplm

  yf(1:n) = y(1:n)

  nyf = n - iar

  do i = 1, nyf

    temp = yfmiss
    k = i + iar

    if ( .not. mvchk ( yf(k), ymiss ) ) then

      temp = yf(k)

      do j = 1, iar

        k = k - 1

        if ( mvchk(yf(k), ymiss)) then
          temp = yfmiss
          exit
        end if

        temp = temp - phi(j) * yf(k)

      end do

    end if

    yf(i) = temp

  end do

  i1 = nyf + 1

  yf(i1:n) = 0.0e0

  return
end
subroutine fltma ( y, n, k, hma, yf, nyf )

!*****************************************************************************80
!
!! FLTMA filters a series using a simple moving average filter.
!
!  Discussion:
!
!    This routine filters the input series y using the k terms
!    of h, copying the filtered series into yf.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real hma
!        the value of each of the simple moving average linear filter
!        coefficients.
!     integer i, ii, i1, j
!        indexing variables.
!     integer k
!        the number of filter terms.
!     integer n
!        the number of observations in the series y.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real sum
!        a temporary location used in computing the filtered series.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  implicit none

  real &
     hma
  integer &
     k,n,nyf
!
!  array arguments
  real &
     y(n),yf(n)
!
!
  real &
     sum
  integer &
     i,i1,ii,j

  yf(1:n) = y(1:n)

  nyf = n - (k - 1)

  do i = 1, nyf
     ii = i - 1
     sum = 0.0e0
     do j = 1, k
        ii = ii + 1
        sum = sum + hma*yf(ii)
     end do
     yf(i) = sum
  end do

  i1 = nyf + 1

  yf(i1:n) = 0.0e0

  return
end
subroutine fltmd ( x, y, n, kmd, sym )

!*****************************************************************************80
!
!! FLTMD applies a modified Daniel filter to a symmetric series.
!
!  Discussion:
!
!    This routine applies one modified daniel filter to a symmetric
!    series.  this routine is adapted from bloomfield's routine moddan.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!  Parameters:
!
!     real con
!        a factor used in the computations.
!     integer kmd
!        the input filter length.
!     integer kused
!        the filter length actually used.
!     integer lim
!        a loop limit.
!     integer n
!        the number of points in the series to be filtered.
!     real sym
!        an indicator variable used to designate whether the series
!        is symmetric (sym = 1.0e0) or not (sym = -1.0e0).
!     real x(n)
!        on input, the series to be filtered.  on output, the
!        smoothed series.
!     real y(n)
!        on input, a work vector.  on output, the input series x.
!
  implicit none

  real &
     sym
  integer &
     kmd,n
!
!  array arguments
  real &
     x(n),y(n)

  real &
     con
  integer &
     i,j,kused,lim
!
!  external functions
  real &
     extend
  external extend

  y(1:n) = x(1:n)

  if (kmd <= 0) return

  kused = kmd + mod(kmd,2)
  if (kused > n) kused = kused - 2

  lim = kused-1
  con = 1.0e0 / real ( 2 * kused )

  do i = 1, n
    x(i) = y(i)

    do j = 1, lim
       x(i) = x(i) + extend(y, i-j, n, sym) &
           + extend(y, i+j, n, sym)
    end do

    x(i) = (x(i) + (extend(y, i-kused, n, sym) &
      + extend(y, i+kused, n, sym)) * 0.5e0) * con

  end do

  return
end
subroutine fltsl ( y, n, k, h, yf, nyf )

!*****************************************************************************80
!
!! FTLSL filters an input series.
!
!  Discussion:
!
!    This routine filters the input series y using the k terms
!    of h, copying the filtered series into yf.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real h(k)
!        the array in which the filter coefficients are stored.
!     integer i, ihm, ihp, ikmid, im, ip
!        indexing variables.
!     integer k
!        the number of filter terms.
!     integer khalf, kmid
!        the half length of the filter and the midpoint of the filter.
!     integer n
!        the number of observations in the series y.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real temp
!        a tempory storage location.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  implicit none

  integer &
     k,n,nyf
!
!  array arguments
  real &
     h(k),y(n),yf(n)

  real &
     temp
  integer &
     i,i1,ihm,ihp,ikmid,im,ip,j,khalf,kmid

  yf(1:n) = y(1:n)

  nyf = n - (k - 1)

  khalf = (k - 1) / 2

  kmid = khalf + 1

  do i = 1, nyf
     ikmid = i + khalf
     temp = h(kmid) * yf(ikmid)
     do 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)
     end do
     yf(i) = temp
  end do

  i1 = nyf + 1

  yf(i1:n) = 0.0e0

  return
end
function gami ( a, x )

!*****************************************************************************80
!
!! GAMI evaluates the incomplete Gamma function.
!
!  Discussion:
!
!    Evaluate the incomplete gamma function defined by
!
!    gami = integral from t = 0 to x of exp(-t) * t**(a-1.0) .
!
!    gami is evaluated for positive values of a and non-negative values
!    of x.  a slight deterioration of 2 or 3 digits accuracy will occur
!    when gami is very large or very small, because logarithmic variables
!    are used.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real a
  real factor
  real gami
  real x
!
!  external functions
  real alngam,gamit
  external alngam,gamit

  if (a <= 0.0) call xerror ('gami    a must be gt zero', 1, 2)
  if (x<0.0) call xerror ('gami    x must be ge zero', 2, 2)

  gami = 0.0
  if (x == 0.0) return
!
!  the only error possible in the expression below is a fatal overflow.
!
  factor = alngam(a) + a*log(x)

  if (factor > log( huge ( factor ) )) then
     gami = huge ( gami )
  else
     gami = exp(factor) * gamit(a,x)
  end if

  return
end
function gamit ( a, x )

!*****************************************************************************80
!
!! GAMIT evaluates Tricomi's incomplete Gamma function.
!
!  Discussion:
!
!    Evaluate Tricomi's incomplete gamma function defined by
!
!    gamit = x**(-a)/gamma(a) * integral t = 0 to x of exp(-t) * t**(a-1.)
!
!    and analytic continuation for a <= 0.0.  gamma(x) is the complete
!    gamma function of x.  gamit is evaluated for arbitrary real values of
!    a and for non-negative values of x (even though gamit is defined for
!    x < 0.0), except that for x = 0 and a <= 0.0, gamit is infinite,
!    a fatal error.
!
!    a slight deterioration of 2 or 3 digits accuracy will occur when
!    gamit is very large or very small in absolute value, because log-
!    arithmic variables are used.  also, if the parameter a is very close
!    to a negative integer (but not a negative integer), there is a loss
!    of accuracy, which is reported if the result is less than half
!    machine precision.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!  Reference:
!
!    Walter Gautschi,
!    An Evaluation Procedure for Incomplete Gamma Functions,
!    ACM Transactions on Mathematical Software.
!
  implicit none

  real a
  real aeps
  real ainta
  real algap1
  real alneps
  real alng
  real alx
  real bot
  real gamit
  real h
  real sga
  real sgngam
  real sqeps
  real t
  real x

  real alngam,gamr,r9gmit,r9lgic,r9lgit
  external alngam,gamr,r9gmit,r9lgic,r9lgit

  data alneps, sqeps, bot / 3*0.0 /

  if ( alneps == 0.0) then
    alneps = -log( 0.5 * epsilon ( alneps ) )
    sqeps = sqrt( epsilon ( sqeps ) )
    bot = log( tiny ( bot ) )
  end if

  if (x<0.0) call xerror ('gamit   x is negative', 2, 2)

  if (x /= 0.0) alx = log(x)
  sga = 1.0
  if (a /= 0.0) sga = sign (1.0, a)
  ainta = aint (a+0.5*sga)
  aeps = a - ainta

  if ( x <= 0.0) then
    gamit = 0.0
    if (ainta > 0.0 .or. aeps /= 0.0) gamit = gamr(a+1.0)
    return
  end if

  if ( x <= 1.0) then
    if (a >= (-0.5) .or. aeps /= 0.0) call algams (a+1.0, algap1, &
      sgngam)
    gamit = r9gmit ( a, x, algap1, sgngam, alx )
    return
  end if

  if ( x <= a ) then
    t = r9lgit (a, x, alngam(a+1.0))
    if (t<bot) call xerclr
    gamit = exp(t)
    return
  end if

  alng = r9lgic ( a, x, alx )
!
!  evaluate gamit in terms of log(gamic(a,x))
!
  h = 1.0

  if ( aeps == 0.0 .and. ainta <= 0.0 ) then
    t = -a*alx + log(abs(h))
    if (t<bot) call xerclr
    gamit = sign (exp(t), h)
    return
  end if

  call algams (a+1.0, algap1, sgngam)

  t = log(abs(a)) + alng - algap1

  if (t > alneps) then
    t = t - a*alx
    if (t<bot) call xerclr
    gamit = -sga*sgngam*exp(t)
    return
  end if

  if (t > (-alneps)) h = 1.0 - sga*sgngam*exp(t)

  if ( abs ( h ) <= sqeps ) then
    call xerclr
    call xerror ('gamit   result lt half precision', 1, 1)
  end if

  t = -a*alx + log(abs(h))
  if (t<bot) call xerclr
  gamit = sign (exp(t), h)

  return
end
subroutine gamlim ( xmin, xmax )

!*****************************************************************************80
!
!! GAMLIM calculates the legal range of input arguments for the Gamma function.
!
!  Discussion:
!
!    Calculate the minimum and maximum legal bounds for x in gamma(x).
!    xmin and xmax are not the only bounds, but they are the only non-
!    trivial ones to calculate.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!  Parameters:
!
!    xmin   minimum legal value of x in gamma(x).  any smaller value of
!    x might result in underflow.
!
!    xmax   maximum legal value of x in gamma(x).  any larger value will
!    cause overflow.
!
  implicit none

  real xmax
  real xmin

  real alnbig,alnsml,xln,xold
  integer i

  alnsml = log( tiny ( alnsml ) )
  xmin = -alnsml
  do i=1,10
    xold = xmin
    xln = log(xmin)
    xmin = xmin - xmin*((xmin+0.5)*xln - xmin - 0.2258 + alnsml) &
      / (xmin*xln + 0.5)
    if (abs(xmin-xold)<0.005) go to 20
  end do

  call xerror ('gamlim  unable to find xmin', 1, 2)

 20   xmin = -xmin + 0.01

  alnbig = log( huge ( alnbig ) )
  xmax = alnbig
  do i=1,10
    xold = xmax
    xln = log(xmax)
    xmax = xmax - xmax*((xmax-0.5)*xln - xmax + 0.9189 - alnbig) &
      / (xmax*xln - 0.5)
    if (abs(xmax-xold)<0.005) go to 40
  end do

  call xerror ('gamlim  unable to find xmax', 2, 2)

 40   xmax = xmax - 0.01
  xmin = max (xmin, -xmax+1.)

  return
end
function gamma ( x )

!*****************************************************************************80
!
!! GAMMA evaluates the Gamma function.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real gamma
  real x

  real dxrel,pi,sinpiy,sq2pil,xmax,xmin,y
  integer i,n,ngcs
!
!  local arrays
  real gcs(23)
!
!  external functions
  real csevl,r9lgmc
  integer inits
  external csevl,r9lgmc,inits

  data gcs   ( 1) / .008571195590989331e0/
  data gcs   ( 2) / .004415381324841007e0/
  data gcs   ( 3) / .05685043681599363e0/
  data gcs   ( 4) /-.004219835396418561e0/
  data gcs   ( 5) / .001326808181212460e0/
  data gcs   ( 6) /-.0001893024529798880e0/
  data gcs   ( 7) / .0000360692532744124e0/
  data gcs   ( 8) /-.0000060567619044608e0/
  data gcs   ( 9) / .0000010558295463022e0/
  data gcs   (10) /-.0000001811967365542e0/
  data gcs   (11) / .0000000311772496471e0/
  data gcs   (12) /-.0000000053542196390e0/
  data gcs   (13) / .0000000009193275519e0/
  data gcs   (14) /-.0000000001577941280e0/
  data gcs   (15) / .0000000000270798062e0/
  data gcs   (16) /-.0000000000046468186e0/
  data gcs   (17) / .0000000000007973350e0/
  data gcs   (18) /-.0000000000001368078e0/
  data gcs   (19) / .0000000000000234731e0/
  data gcs   (20) /-.0000000000000040274e0/
  data gcs   (21) / .0000000000000006910e0/
  data gcs   (22) /-.0000000000000001185e0/
  data gcs   (23) / .0000000000000000203e0/

  data pi /3.14159265358979324e0/
! sq2pil is log (sqrt (2.*pi) )
  data sq2pil /0.91893853320467274e0/
  data ngcs, xmin, xmax, dxrel /0, 3*0.0 /
!
!  initialize.  find legal bounds for x, and determine the number of
!  terms in the series required to attain an accuracy ten times better
!  than machine precision.
!
  if ( ngcs == 0) then

    ngcs = inits (gcs, 23, 0.05 * epsilon ( x ) )

    call gamlim (xmin, xmax)
    dxrel = sqrt ( epsilon ( dxrel ) )

  end if
!
!  finish initialization.  start evaluating gamma(x).
!
  y = abs(x)
  if (y > 10.0) go to 50
!
!  compute gamma(x) for abs(x) <= 10.0.  reduce interval and
!  find gamma(1+y) for 0. <= y < 1. first of all.
!
  n = int ( x )
  if (x<0.0 ) n = n - 1
  y = x - real ( n )
  n = n - 1
  gamma = 0.9375 + csevl(2.0*y-1.0, gcs, ngcs)

  if (n == 0) return

  if ( 0 < n ) then

    do i=1,n
      gamma = (y+real ( i ))*gamma
    end do

  else

    n = -n
    if (x == 0.0 ) call xerror ('gamma   x is 0', 4, 2)
    if (x<0. .and. x+ real ( n-2 ) == 0.0) call xerror ( &
      'gamma   x is a negative integer', 4, 2)

    if (x<(-0.5) .and. abs((x-aint(x-0.5))/x)<dxrel) then
      call xerror (  &
        'gamma   answer lt half precision, x too near negative integer', &
        1, 1)
    end if

    do i=1,n
      gamma = gamma / (x+real ( i-1 ) )
    end do

  end if

  return
!
!  compute gamma(x) for abs(x) > 10.0.  recall y = abs(x).
!
 50   if (x > xmax) call xerror ('gamma   x so big gamma overflows', &
    3, 2)

  gamma = 0.0

  if (x<xmin) then
    call xerror ('gamma   x so small gamma underflows', 2, 1)
  end if

  if (x<xmin) then
    return
  end if

  gamma = exp((y-0.5)*log(y) - y + sq2pil + r9lgmc(y) )

  if (x > 0.) then
    return
  end if

  if (abs((x-aint(x-0.5))/x)<dxrel) then
    call xerror ( &
    'gamma   answer lt half precision, x too near negative integer', &
    1, 1)
  end if

  sinpiy = sin ( pi * y )

  if (sinpiy == 0.0 ) then
    call xerror ( 'gamma   x is a negative integer', 4, 2)
  end if

  gamma = - pi / ( y * sinpiy * gamma )

  return
end
function gamr ( x )

!*****************************************************************************80
!
!! GAMR computes the reciprocal of the Gamma function.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real alngx
  real gamma
  real gamr
  integer irold
  real sgngx
  real x

  gamr = 0.0
  if (x <= 0.0 .and. aint(x) == x) return

  call xgetf (irold)
  call xsetf (1)

  if ( abs(x) <= 10.0) then
    gamr = 1.0/gamma(x)
    call xerclr
    call xsetf (irold)
  else
    call algams (x, alngx, sgngx)
    call xerclr
    call xsetf (irold)
    gamr = sgngx * exp(-alngx)
  end if

  return
end
subroutine geni ( ivect, n, iinit, istp )

!*****************************************************************************80
!
!! GENI assigns an arithmetic sequence of values into an integer vector.
!
!  Discussion:
!
!    This routine puts values iinit step istp through iinit + (n - 1)*istp 
!    into a vector ivect of length n.  no error checking is done.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        initialization value.
!     integer iinit, istp
!        input parameters.  the initial value and the increment used
!        in creating the initialization values.
!     integer ivect(n)
!        output parameter.  the vector into which to put the values
!        iinit, iinit + istp, ..., iinit + (n - 1)*istp.
!     integer j
!        loop parameter.
!     integer n
!        input parameter.  the length of ivect.
!
  implicit none

  integer &
     iinit,istp,n
!
!  array arguments
  integer &
     ivect(n)

  integer &
     i,j

  i = iinit
  do j=1,n
     ivect(j) = i
     i = i + istp
  end do

  return
end
subroutine genr ( rvect, n, rinit, rstp )

!*****************************************************************************80
!
!! GENR puts an arithmetic sequence of values into a real vector.
!
!  Discussion:
!
!    This routine puts values rinit step rstp through rinit + (n - 1)*rstp into
!    a vector rvect of length n.  no error checking is done.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer j
!        loop parameter.
!     integer n
!        input parameter.  the length of rvect.
!     real r
!        initialization value.
!     real rinit, rstp
!        input parameters.  the initial value and the increment used
!        in creating the initialization values.
!     real rvect(n)
!        output parameter.  the vector into which to put the values
!        rinit, rinit + rstp, ..., rinit + (n - 1)*rstp.
!
  implicit none

  real &
     rinit,rstp
  integer &
     n
!
!  array arguments
  real &
     rvect(n)

  real &
     r
  integer &
     j

  r = rinit
  do j=1,n
     rvect(j) = r
     r = r + rstp
  end do

  return
end
subroutine getpi ( pi )

!*****************************************************************************80
!
!! GETPI returns the value of PI.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real pi

  pi = 3.141592653589793238462643383279e0

  return
end
subroutine gfaest ( phi, iar, nf, freq, gain, phas, delta )

!*****************************************************************************80
!
!! GFAEST computes the gain of an autoregressive linear filter.
!
!  Discussion:
!
!    This routine computes the gain function of an autoregressive
!    linear filter using the algorithm given on pages 419 and 420
!    jenkins and watts.
!
!  Modified:
!
!    25 April 2006
!
!  Reference:
!
!    Gwilym Jenkins, Donald Watts,
!    Spectral Analysis and its Applications,
!    Holden-Day 1968.
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta
  integer &
     iar,nf
!
!  array arguments
  real &
     freq(nf),gain(nf),phas(nf),phi(iar)

  real &
     arg,c,pi,s,v0,v1,v2,z0,z1,z2
  integer &
     i,j,jj
!
!  external subroutines
  external getpi
!
!     variable definitions (alphabetically)
!
!     real arg
!        a value used to compute the gain function estimates.
!     real c
!        a value used to compute the gain function estimates.
!     real delta
!        the sampling interval of the original series.
!     real freq(nf)
!        the vector of frequencies at which the gain function is to
!        be estimated.
!     real gain(nf)
!        the array in which the gain function estimates are returned.
!     integer i
!        an index variable.
!     integer iar
!        the number of filter coefficients.
!     integer j, jj
!        index variables.
!     integer nf
!        the number of frequencies for which the gain function estimates
!        are to be computed.
!     real phas(nf)
!        the array in which the phase of the filter is returned.
!     real phi(iar)
!        the vector containing the autoregressive filter coefficients.
!     real pi
!        the value of pi.
!     real s
!        a value used to compute the gain function estimates.
!     real v0, v1, v2
!        constants used for computing the gain function estimates.
!     real z0, z1, z2
!        constants used for computing the gain function estimates.
!
  call getpi(pi)
!
!  compute gain function estimates and their confidence limits.
!
  do i = 1, nf

     if (freq(i) == 0.0e0) then
        arg = 0.0e0
        c = 1.0e0
        s = 0.0e0
     else if (freq(i) == 0.25e0) then
        arg = pi/2.0e0
        c = 0.0e0
        s = 1.0e0
     else if (freq(i) == 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

     jj = iar + 1

     do j = 1, iar
        jj = jj -1

        v2 = c * v1 - v0 - phi(jj)
        v0 = v1
        v1 = v2

        z2 = s * z1 - z0 - phi(jj)
        z0 = z1
        z1 = z2
     end do

     v2 = delta * (1.0e0 + (v1 * c - v0))

     z2 = delta * z1 * s

     gain(i) = sqrt(v2*v2 + z2*z2)

     phas(i) = -0.5e0 * pi
     if (z2 /= 0.0e0 .and. v2 /= 0.0e0) phas(i) = atan2(z2, v2)

  end do

  return
end
subroutine gfarf ( phi, iar )

!*****************************************************************************80
!
!! GFARF: short call to compute gain function of autoregressive filter.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iar
!
!  array arguments
  real &
     phi(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     delta,fmax,fmin,ypltmn,ypltmx
  integer &
     igferr,nf,nord,nprt
  logical &
     err01,head,sym
!
!  local arrays
  real &
     freq(101),gain(101),phas(101),xord(101),yord(101)
  integer &
     isort(101)
  character &
     liar(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,gfaest,gford,gfout,setfrq
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the sampling interval.
!     logical err01
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real fmax, fmin
!        the minimum and maximum frequency for which the gain
!        function is to be estimated.
!     real freq(101)
!        the vector of frequencies at which the gain function
!        has been estimated.
!     real gain(101)
!        the vector in which the gain function estimates are
!        stored.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer iar
!        the number of filter coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer igferr
!        an error flag indicating whether computations seem
!        to have produced reasonable results.
!     integer isort(101)
!        an array used for sorting.
!     character*1 liar(8)
!        the array containing the name of the variable iar.
!     integer nf
!        the number of frequencies at which the gain function
!        is to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nord
!        the number of values to be plotted.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     real phas(101)
!        the array in which the phase of the filter is returned.
!     real phi(iar)
!        the vector containing the filter coefficients.
!     logical sym
!        the variable used to indicate whether the gain function
!        computed was for a symmetric or autoregressive filter.
!     real xord(101)
!        the x coordinates for the gain function plot
!     real yord(101)
!        the y coordinates for the gain function plot
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, liar, iar, 1, 1, head, err01, liar)

  if ( err01 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  sym = .false.

  nf = 101

  fmin = 0.0e0
  fmax = 0.5e0

  delta = 1.0e0

  nprt = -1
!
!  set frequencies at which the gain function is to be estimated
!
  call setfrq (freq, nf, nprt, fmin, fmax, delta)
!
!  compute the gain function
!
  call gfaest (phi, iar, nf, freq, gain, phas, delta)
!
!  set the coordinates for the plot.
!
  call gford (freq, gain, isort, nf, xord, yord, nord, &
     ypltmn, ypltmx, nprt, igferr)
!
!  plot the results.
!
  call gfout (xord, yord, nord, freq, phas, nf, iar, sym, fmin, &
     fmax, ypltmn, ypltmx, nprt, igferr, nmsub)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call gfarf (phi, iar)')
end
subroutine gfarfs ( phi, iar, nf, fmin, fmax, gain, phas, freq, &
  nprt, ldstak )

!*****************************************************************************80
!
!! GFARFS: short call to compute gain function of autoregressive filter.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin
  integer &
     iar,ldstak,nf,nprt
!
!  array arguments
  real &
     freq(*),gain(*),phas(*),phi(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     delta,fmn,fmx,ypltmn,ypltmx
  integer &
     igferr,io,isort,ldsmin,nall0,nord,xord,yord
  logical &
     err01,err02,err03,head,sym
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     liar(8)*1,llds(8)*1,lnf(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external eisge,gfaest,gford,gfout,ldscmp,setfrq,stkclr, &
     stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03
!        values indicating whether an error was detected (true) or not
!        (false).
!     real fmax, fmin
!        the minimum and maximum frequency for which the gain
!        function is to be estimated.
!     real fmn, fmx
!        the frequency range actually used.
!     real freq(nf)
!        the vector of frequencies at which the gain function
!        has been estimated.
!     real gain(nf)
!        the vector in which the gain function estimates are
!        stored.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer iar
!        the number of filter coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer igferr
!        an error flag indicating whether computations seem
!        to have produced reasonable results.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output.
!     integer isort
!        the starting location in istak for
!        the array used for sorting.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        the length of the array dstak.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     character*1 liar(8), llds(8), lnf(8)
!        the arrays containing the names of checked variables
!     integer nall0
!        the number of outstanding stack allocations.
!     integer nf
!        the number of frequencies at which the gain function
!        is to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nord
!        the number of points to be plotted.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     real phas(nf)
!        the array in which the phase of the filter is returned.
!     real phi(iar)
!        the vector containing the filter coefficients.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     logical sym
!        the variable used to indicate whether the gain function
!        computed was for a symmetric or autoregressive filter.
!     integer xord
!        the starting location in rstak/dstak of
!        the x coordinates for the gain function plot
!     integer yord
!        the starting location in rstak/dstak of
!        the y coordinates for the gain function plot
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  io = 1
  if (nprt == 0) io = 0

  call eisge(nmsub, liar, iar, 1, 1, head, err01, liar)

  call eisge(nmsub, lnf, nf, 1, 1, head, err02, lnf)

  if (err02) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call ldscmp(3*io, 0, nf, 0, 0, 0, 's', 2*io*nf, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds)

  if (err01.or.err02.or.err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  if (nprt  /=  0) then
    call stkset (ldstak, 4)
    nall0 = stkst(1)
  else
    nall0 = 0
  end if

  sym = .false.

  delta = 1.0e0
!
!  set frequencies at which the gain function is to be estimated
!
  fmn = max(fmin, 0.0e0)
  fmx = min(fmax, 0.5e0)
  if (fmn >= fmx) then
    fmn = 0.0e0
    fmx = 0.5e0
  end if
  call setfrq (freq, nf, 2, fmn, fmx, delta)
!
!  compute the gain function
!
  call gfaest (phi, iar, nf, freq, gain, phas, delta)

  if (nprt == 0) return
!
!  set various pointers for the plotting arrays
!
  xord = stkget(nf, 3)
  yord = stkget(nf, 3)

  isort = stkget(nf, 2)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  plot the results
!
  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)

  call stkclr(nall0)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
   '       call gfarfs (phi, iar,'/ &
   '      +             nf, fmin, fmax, gain, phas, freq, nprt,', &
   ' ldstak)')
end
subroutine gford ( freq, gain, isort, nf, xord, yord, &
  nord, ypltmn, ypltmx, nprt, igferr )

!*****************************************************************************80
!
!! GFORD produces ordinants for the gain function plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     ypltmn,ypltmx
  integer &
     igferr,nf,nord,nprt
!
!  array arguments
  real &
     freq(nf),gain(nf),xord(nf),yord(nf)
  integer &
     isort(nf)

  real &
     gainmn,gainmx,ymax
  integer &
     i,j
!
!  external subroutines
  external spcck
!
!     variable definitions (alphabetically)
!
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     real gain(nf)
!        the vector in which the gain function is stored.
!     real gainmn, gainmx
!        the minimum and maximum gain function value to be plotted.
!     integer i
!        an index variable
!     integer igferr
!        an error flag indicating whether computations seem
!        to have produced reasonable results.
!     integer isort(nf)
!        the array used for sorting.
!     integer j
!        an indexing variable.
!     integer nf
!        the number of frequencies for which the spectral estimates
!        are to be estimated.
!     integer nord
!        the number of ordinates to be plotted.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     real xord(nf)
!        the x ordinates for the spectrum plot.
!     real ymax
!        the maximum actual spectrum value (in decibels) to be plotted.
!     real yord(nf)
!        the y ordinates for the spectrum plots.
!     real ypltmn, ypltmx
!        the minimum and maximum vaues to be plotted for the y axis.
!
  igferr = 0

  call spcck ( gain, isort, nf, gainmn, gainmx, nord, igferr )

  if (igferr  /=  0) then
    return
  end if

  j = 0
!
!  Set ordinates for decibel plots
!
  if ( nprt < 1 ) then

    ymax = 10.0e0 * log10(gainmx)

    ypltmx = 0.0e0
    ypltmn = 10.0e0 * log10(gainmn) - ymax

    do i = 1, nf
      if ( gainmn <= gain(i) ) then
        j = j + 1
        xord(j) = freq(i)
        yord(j) = 10.0e0 * log10(gain(i)) - ymax
      end if
    end do
!
!  Set ordinates for log plots.
!
  else

    ypltmx = gainmx
    ypltmn = gainmn

    do i = 1, nf
      if ( gainmn <= gain(i) ) then
        j = j + 1
        xord(j) = freq(i)
        yord(j) = gain(i)
      end if
    end do

  end if

  return
end
subroutine gfout ( xord, yord, nord, freq, phas, nf, &
  nterm, sym, xpltmn, xpltmx, ypltmn, ypltmx, nprt, igferr, &
  nmsub )

!*****************************************************************************80
!
!! GFOUT produces the gain function plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        an error flag.
!     real freq(nf)
!        the vector of frequencies at which the gain function is to
!        be estimated.
!     integer ierr
!        the error flag.
!     integer igferr
!        an error flag indicating whether computations seem
!        to have produced reasonable results.
!     integer ilog
!        the variable controlling the plot axis type (log or linear)
!     integer isym(1)
!        a dummy array for the call to PPMN.
!     integer nf
!        the number of frequencies for which the gain function estimates
!        are to be computed.
!     character*1 nmsub(6)
!        the name of the calling subroutine.
!     integer nord
!        the number of ordinates to be plotted.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nterm
!        the number of terms in the filter for which the gain
!        function was computed.
!     real phas(nf)
!        the array in which the phase of the filter is returned.
!     real pi
!        the value of pi.
!     logical sym
!        an indicator variable used to determine if the filter was
!        symmetric or not.
!     real xmn, xmx
!        ...
!     real xord(nord)
!        the x coordinates for the gain function plot
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real ymn, ymx
!        ...
!     real yord(nord)
!        the y coordinates for the gain function plot
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
  implicit none

  real &
     xpltmn,xpltmx,ypltmn,ypltmx
  integer &
     igferr,nf,nord,nprt,nterm
  logical &
     sym
!
!  array arguments
  real &
     freq(nf),phas(nf),xord(nord),yord(nord)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr

  real &
     pi,xmn,xmx,ymn,ymx
  integer &
     ilog
  logical &
     error
!
!  local arrays
  integer &
     isym(1)
!
!  common blocks
  common /errchk/ierr

!
!  set output width.
!
  call versp(.true.)

  if (sym) write ( *, 1000) nterm
  if (.not. sym) write ( *, 1003) nterm

  if ( igferr /= 0 ) then
    write ( *, 1004)
    return
  end if

  if (nprt >= 1) then
    ilog = 1
  else
    ilog = 0
  end if
!
!  Determine the bounds for the x and y axis and complete the
!  error checking.
!
  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

  if (xpltmn  ==  0.0e0 .and. xpltmx ==  0.5e0) then
    write ( *, 1002)
  end if

  if ( sym ) then
    return
  end if

  write ( *, 1006)

  call versp(.true.)
!
!  Print phase plot for autoregressive filter.
!
  call getpi(pi)

  write ( *, 1005) nterm

  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

  if (xpltmn /= 0.0e0 .or. xpltmx /= 0.5e0) then
    return
  end if

  write ( *, 1002)

  return

 1000 format (' gain function of ', i3, ' term symmetric', &
     ' linear filter')
 1002 format('+freq'/ &
     ' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, '6.6667', 4x, &
     '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, '2.5', 7x, &
     '2.2222', 4x, '2.')
 1003 format (' gain function of ', i3, ' term autoregressive,', &
     ' or difference, filter')
 1004 format (//' the plot has been supressed because fewer than two'/ &
     ' non zero gain function values were computed.')
 1005 format (' phase function of ', i3, ' term autoregressive,', &
     ' or difference, filter')
 1006 format ('1')
end
subroutine gfsest ( h, k, nf, freq, gain, delta )

!*****************************************************************************80
!
!! GFSEST: gain function of symmetric linear filter with given frequencies.
!
!  Discussion:
!
!    This routine computes the gain function of an input symmetric
!    linear filter at the frequencies specified in freq using the
!    transform algorithm shown on page 311 of jenkins and watts.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Gwilym Jenkins, Donald Watts,
!    Spectral Analysis and its Applications,
!    Holden-Day 1968.
!
!  Parameters:
!
!     real c
!        a value used to compute the gain function.
!     real delta
!        the sampling interval of the original series.
!     real freq(nf)
!        the vector of frequencies at which the gain function is to be
!        estimated.
!     real gain(nf)
!        the array in which the gain function estimates are returned.
!     real h(k)
!        the symmetric linear filter weights.
!     integer i, j
!        index variables.
!     integer k
!        the number of terms in the symmetric linear filter.
!     integer khalf, kmid
!        half the filter length, and the midpoint of the filter,
!        respectively.
!     integer nf
!        the number of frequencies for which the gain function estimates
!        are to be estimated.
!     real pi
!        the value of pi.
!     real v0, v1, v2
!        constants used for computing the gain function estimates.
!
  implicit none

  real &
     delta
  integer &
     k,nf
!
!  array arguments
  real &
     freq(nf),gain(nf),h(k)
!
!
  real &
     c,pi,v0,v1,v2
  integer &
     i,j,khalf,kmid
!
!  external subroutines
  external getpi

  call getpi(pi)
!
!   compute gain function estimates and their confidence limits.
!
  kmid = (k+1) / 2
  khalf = kmid - 1

  do i = 1, nf
     c = cos(2.0e0 * pi * freq(i))
     v0 = 0.0e0
     v1 = 0.0e0
     do j = 1, khalf
        v2 = 2.0e0 * c * v1 - v0 + h(j)
        v0 = v1
        v1 = v2
     end do
     gain(i) = abs(delta * (h(kmid) + 2.0e0 * (v1 * c - v0)))
  end do

  return
end
subroutine gfslf ( h, k )

!*****************************************************************************80
!
!! GFSLF: short call for gain function of symmetric linear filter.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     k
!
!  array arguments
  real &
     h(*)
!
!  scalars in common
  integer &
     ierr

  real &
     delta,fmax,fmin,ypltmn,ypltmx
  integer &
     igferr,nf,nord,nprt
  logical &
     err01,err02,err03,head,sym
!
!  local arrays
  real &
     freq(101),gain(101),xord(101),yord(101)
  integer &
     isort(101)
  character &
     lh(8)*1,lk(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,eriodd,erslf,gford,gfout,gfsest,setfrq
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the sampling interval.
!     logical err01, err02, err03
!        values indicating whether an error was detected (true) or not
!        (false).
!     real fmax, fmin
!        the minimum and maximum frequency for which the gain
!        function is to be estimated.
!     real freq(101)
!        the vector of frequencies at which the gain function
!        has been estimated.
!     real gain(101)
!        the vector in which the gain function estimates are
!        stored.
!     real h(k)
!        the array of symmetric linear filter coefficients.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer igferr
!        an error flag indicating whether computations seem
!        to have produced reasonable results.
!     integer isort(101)
!        the array used for sorting.
!     integer k
!        the number of filter terms.
!     character*1 lh(8), lk(8)
!        the array containing the name of the variables h and k.
!     integer nf
!        the number of frequencies at which the gain function
!        is to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nord
!        the number of points to be plotted.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     logical sym
!        the variable used to indicate whether the gain function
!        computed was for a symmetric or autoregressive filter.
!     real xord(101)
!        the x coordinates for the gain function plot
!     real yord(101)
!        the y coordinates for the gain function plot
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.
!
!  call error checking routines
!
  call eisge(nmsub, lk, k, 1, 1, head, err01, lk)

  call eriodd(nmsub, lk, k, 1, head, err02)

  if ((.not. err01) .and. (.not. err02)) then
     call erslf(nmsub, lh, k, h, head, err03)
  else
     err03 = .false.
  end if

  if (err01 .or. err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  sym = .true.
  nf = 101

  fmin = 0.0e0
  fmax = 0.5e0

  delta = 1.0e0

  nprt = -1
!
!  set frequencies at which the gain function is to be estimated
!
  call setfrq (freq, nf, nprt, fmin, fmax, delta)
!
!  compute the gain function
!
  call gfsest (h, k, nf, freq, gain, delta)
!
!  plot the results
!
  call gford (freq, gain, isort, nf, xord, yord, nord, &
     ypltmn, ypltmx, nprt, igferr)

  call gfout (xord, yord, nord, freq, gain, nf, k, &
     sym, fmin, fmax, ypltmn, ypltmx, nprt, igferr, nmsub)

  return
 1000 format (/' the correct form of the call statement is'// &
     '       call gfslf (h, k)')
end
subroutine gfslfs ( h, k, nf, fmin, fmax, gain, freq, nprt, ldstak )

!*****************************************************************************80
!
!! GFSLFS: short call for gain function of symmetric linear filter.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin
  integer &
     k,ldstak,nf,nprt
!
!  array arguments
  real &
     freq(*),gain(*),h(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     delta,fmn,fmx,ypltmn,ypltmx
  integer &
     igferr,io,isort,ldsmin,nall0,nord,xord,yord
  logical &
     err01,err02,err03,err04,err05,head,sym
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     lh(8)*1,lk(8)*1,llds(8)*1,lnf(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external eisge,eriodd,erslf,gford,gfout,gfsest,ldscmp, &
     setfrq,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03, err04, err05
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real fmax, fmin
!        the minimum and maximum frequency for which the gain
!        function is to be estimated.
!     real fmn, fmx
!        the frequency range actually used.
!     real freq(nf)
!        the vector of frequencies at which the gain function
!        has been estimated.
!     real gain(nf)
!        the vector in which the gain function estimates are
!        stored.
!     real h(k)
!        the array of symmetric linear filter coefficients.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer igferr
!        an error flag indicating whether computations seem
!        to have produced reasonable results.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output.
!     integer isort
!        the starting location in istak for
!        the array used for sorting.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer k
!        the number of filter terms.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 lh(8), lk(8), llds(8), lnf(8)
!        the arrays containing the names of the checked variables
!     integer nall0
!        the number of outstanding stack allocations.
!     integer nf
!        the number of frequencies at which the gain function
!        is to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nord
!        the number of points to be plotted.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     logical sym
!        the variable used to indicate whether the gain function
!        computed was for a symmetric or autoregressive filter.
!     integer xord
!        the starting location in rstak/dstak of
!        the x coordinates for the gain function plot
!     integer yord
!        the starting location in rstak/dstak of
!        the y coordinates for the gain function plot
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  io = 1
  if (nprt == 0) io = 0
!
!  call error checking routines
!
  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)

  if (err04) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  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)

  if (err01 .or. err02 .or. err03 .or. err05) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  if (nprt  /=  0) then
    call stkset (ldstak, 4)
    nall0 = stkst(1)
  else
    nall0 = 0
  end if

  sym = .true.

  delta = 1.0e0
!
!  set frequencies at which the gain function is to be estimated
!
  fmn = max(fmin, 0.0e0)
  fmx = min(fmax, 0.5e0)
  if (fmn >= fmx) then
    fmn = 0.0e0
    fmx = 0.5e0
  end if
  call setfrq (freq, nf, 2, fmn, fmx, delta)
!
!  compute the gain function
!
  call gfsest (h, k, nf, freq, gain, delta)

  if (nprt == 0) return
!
!  set various pointers for the plotting arrays
!
  xord = stkget(nf, 3)
  yord = stkget(nf, 3)

  isort = stkget(nf, 2)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  plot the results
!
  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)

  call stkclr(nall0)

  if (ierr == 1) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call gfslfs (h, k, nf, fmin, fmax, gain, freq, nprt,', &
     ' ldstak)')
end
subroutine gmean ( y, n, ymean )

!*****************************************************************************80
!
!! GMEAN computes the geometric mean of a series.
!
!  Discussion:
!
!    The series values must be nonzero.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer n
!        the number of observations in the series
!     real y(n)
!        the vector containing the observed series
!     real ymean
!        the geometric mean of the observed series
!
  implicit none

  integer n

  real ymean
  real y(n)

  ymean = sum ( log ( y(1:n) ) )

  ymean = exp ( ymean / real ( n ) )

  return
end
subroutine gqtstp ( d, dig, dihdi, ka, l, p, step, v, w )

!***********************************************************************
!
!! GQTSTP computes the Goldfeld-Quandt-Trotter step by More-Hebden technique.
!
!  Discussion:
!
!    Given the compactly stored lower triangle of a scaled
!    hessian approximation and a nonzero scaled gradient vector,
!    this routine computes a Goldfeld-Quandt-Trotter step of
!    approximate length V(RADIUS) by the More-Hebden technique.
!
!    In other words, STEP is computed to approximately minimize
!      PSI(STEP) = G' * STEP + 0.5 * STEP' * H * STEP
!    such that the 2-norm of D * STEP is at most approximately V(RADIUS),
!    where G is the gradient, H is the hessian, and D is a diagonal
!    scale matrix whose diagonal is stored in the parameter D.
!
!    GQTSTP assumes:
!
!      DIG = inverse ( D ) * G,
!      DIHDI = inverse ( D ) * H * inverse ( D ).
!
!    If G = 0, however, STEP = 0 is returned, even at a saddle point.
!
!    If it is desired to recompute STEP using a different value of
!    V(RADIUS), then this routine may be restarted by calling it
!    with all parameters unchanged except V(RADIUS).  This explains
!    why STEP and W are listed as I/O.  On an initial call, with
!    KA < 0, STEP and W need not be initialized and only components
!    V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), and
!    V(RAD0) of V must be initialized.  To compute STEP from a saddle
!    point, where the true gradient vanishes and H has a negative
!    eigenvalue, a nonzero G with small components should be passed.
!
!    This routine is called as part of the NL2SOL package, but it could
!    be used in solving any unconstrained minimization problem.
!
!    The desired G-Q-T step (references 2, 3, 4) satisfies
!    (H + ALPHA*D**2) * STEP = -G  for some nonnegative ALPHA such that
!    H + ALPHA*D**2 is positive semidefinite.  ALPHA and STEP are
!    computed by a scheme analogous to the one described in reference 5.
!    Estimates of the smallest and largest eigenvalues of the hessian
!    are obtained from the Gerschgorin circle theorem enhanced by a
!    simple form of the scaling described in reference 6.
!
!    Cases in which H + ALPHA*D**2 is nearly or exactly singular are
!    handled by the technique discussed in reference 2.  In these
!    cases, a step of exact length V(RADIUS) is returned for which
!    PSI(STEP) exceeds its optimal value by less than
!    -V(EPSLON)*PSI(STEP).
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    Algorithm 573:
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
!    David Gay,
!    Computing Optimal Locally Constrained Steps,
!    SIAM Journal on Scientific and Statistical Computing,
!    Volume 2, Number 2, pages 186-197, 1981.
!
!    Steven Goldfeld, Richard Quandt, Hale Trotter,
!    Maximization by Quadratic Hill-climbing,
!    Econometrica,
!    Volume 34, pages 541-551, 1966.
!
!    MD Hebden,
!    An Algorithm for Minimization using Exact Second Derivatives,
!    Tehcnical Report TP515,
!    Theoretical Physics Division,
!    AERE, Harwell, Oxon., England, 1973.
!
!    Jorge More,
!    The Levenberg-Marquardt Algorithm, Implementation and Theory,
!    in Springer Lecture Notes in Mathematics, Number 630,
!    edited by G A Watson,
!    Springer, 1978.
!
!    Richard Varga,
!    Minimal Gerschgorin Sets,
!    Pacific Journal of Mathematics,
!    Volume 15, pages 719-729, 1965.
!
!  Parameters:
!
!    Input, real D(P), the scale vector, that is, the diagonal of the scale
!    matrix D mentioned above.
!
!    Input, real DIG(P), the scaled gradient vector, inverse ( D ) * G.
!    If G = 0, then STEP = 0 and V(STPPAR) = 0 are returned.
!
!    Input, real DIHDI((P*(P+1))/2), the lower triangle of the scaled
!    hessian approximation, that is,
!      inverse ( D ) * H * inverse ( D ),
!    stored compactly by rows, in the order (1,1), (2,1), (2,2), (3,1),
!    (3,2), and so on.
!
!    Input/output, integer KA, the number of Hebden iterations taken so
!    far to determine STEP.  KA < 0 on input means this is the first
!    attempt to determine STEP for the present DIG and DIHDI.
!    KA is initialized to 0 in this case.  Output with KA = 0  or
!    V(STPPAR) = 0 means STEP = -inverse(H)*G.
!
!     l (i/o) = workspace of length p*(p+1)/2 for cholesky factors.
!
!     p (in)  = number of parameters -- the hessian is a  p x p  matrix.
!
!  step (i/o) = the step computed.
!
!     v (i/o) contains various constants and variables described below.
!
!     w (i/o) = workspace of length 4*p + 6.
!
!  entries in v
!
! v(dgnorm) (i/o) = 2-norm of (d**-1)*g.
! v(dstnrm) (output) = 2-norm of d * step.
! v(dst0)   (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or
!             overestimate of smallest eigenvalue of (d**-1)*h*(d**-1).
! v(epslon) (in)  = max. relative error allowed for psi(step).  for the
!             step returned, psi(step) will exceed its optimal value
!             by less than -v(epslon)*psi(step).  suggested value = 0.1.
! v(gtstep) (out) = inner product between g and step.
! v(nreduc) (out) = psi(-(h**-1)*g) = psi(Newton step)  (for pos. def.
!             h only -- v(nreduc) is set to zero otherwise).
! v(phmnfc) (in)  = tol. (together with v(phmxfc)) for accepting step
!             (More's sigma).  the error v(dstnrm) - v(radius) must lie
!             between v(phmnfc)*v(radius) and v(phmxfc)*v(radius).
! v(phmxfc) (in)  (see v(phmnfc).)
!             suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5.
! v(preduc) (out) = psi(step) = predicted obj. func. reduction for step.
! v(radius) (in)  = radius of current (scaled) trust region.
! v(rad0)   (i/o) = value of v(radius) from previous call.
! v(STPPAR) (i/o) is normally the Marquardt parameter, i.e. the alpha
!             described below under algorithm notes.  if h + alpha*d**2
!             (see algorithm notes) is (nearly) singular, however,
!             then v(STPPAR) = -alpha.
!
  implicit none

  integer p

  real aki
  real akk
  real alphak
  real d(p)
  real delta
  integer dggdmx
  integer, parameter :: dgnorm = 1
  real, save :: dgxfac = 0.0E+00
  integer diag
  integer diag0
  real dig(p)
  real dihdi((p*(p+1))/2)
  real dotprd
  real dst
  integer, parameter :: dst0 = 3
  integer, parameter :: dstnrm = 2
  integer dstsav
  integer emax
  integer emin
  real, parameter :: epsfac = 50.0E+00
  integer, parameter :: epslon = 19
  real epso6
  integer, parameter :: gtstep = 4
  integer i
  integer inc
  integer irc
  integer j
  integer k
  integer k1
  integer ka
  integer kalim
  real, parameter :: kappa = 2.0E+00
  real l((p*(p+1))/2)
  real lk
  integer lk0
  real lsvmin
  integer, parameter :: nreduc = 6
  real oldphi
  real phi
  real phimax
  real phimin
  integer phipin
  integer, parameter :: phmnfc = 20
  integer, parameter :: phmxfc = 21
  integer, parameter :: preduc = 7
  real psifac
  integer q
  integer q0
  real rad
  integer, parameter :: rad0 = 9
  integer, parameter :: radius = 8
  logical restrt
  real root
  real si
  real sk
  real step(p)
  integer, parameter :: stppar = 5
  real sw
  real t
  real t1
  real twopsi
  real uk
  integer uk0
  real v(21)
  real v2norm
  real w(4*p+7)
  real wi
  integer x
  integer x0
!
!  Store largest absolute entry in inverse(D)*H*inverse(D) at W(DGGDMX).
!
  dggdmx = p + 1
!
!  Store Gerschgorin over- and underestimates of the largest
!  and smallest eigenvalues of inverse(D)*H*inverse(D) at W(EMAX)
!  and W(EMIN) respectively.
!
  emax = dggdmx + 1
  emin = emax + 1
!
!  For use in recomputing step, the final values of LK, UK, DST,
!  and the inverse derivative of More's PHI at 0, for positive definite
!  H, are stored in W(LK0), W(UK0), W(DSTSAV), and W(PHIPIN)
!  respectively.
!
  lk0 = emin + 1
  phipin = lk0 + 1
  uk0 = phipin + 1
  dstsav = uk0 + 1
!
!  Store diagonal of inverse(D)*H*inverse(D) in W(DIAG:DIAG+P-1).
!
  diag0 = dstsav
  diag = diag0 + 1
!
!  Store -D * STEP in W(Q:Q+P-1).
!
  q0 = diag0 + p
  q = q0 + 1
  rad = v(radius)
!
!  PHITOL = maximum error allowed in DST = V(DSTNRM) = 2-norm of
!  D * STEP.
!
  phimax = v(phmxfc) * rad
  phimin = v(phmnfc) * rad
!
!  EPSO6 and PSIFAC are used in checking for the special case
!  of nearly singular H + ALPHA*D**2.  See reference 2.
!
  psifac = 2.0E+00 * v(epslon) &
    / ( 3.0E+00 * ( 4.0E+00 * ( v(phmnfc) + 1.0E+00 ) * &
    ( kappa + 1.0E+00 )  +  kappa  +  2.0E+00 ) * rad**2 )
!
!  OLDPHI is used to detect limits of numerical accuracy.  If
!  we recompute step and it does not change, then we accept it.
!
  oldphi = 0.0E+00
  epso6 = v(epslon) / 6.0E+00
  irc = 0
  restrt = .false.
  kalim = ka + 50
!
!  Start or restart, depending on KA.
!
  if ( 0 <= ka ) then
!
!  Restart with new radius.
!
!  Prepare to return Newton step.
!
    if ( 0.0E+00 < v(dst0) .and. v(dst0) - rad <= phimax ) then

      restrt = .true.
      ka = ka + 1
      k = 0
      do i = 1, p
        k = k + i
        j = diag0 + i
        dihdi(k) = w(j)
      end do
      uk = -1.0E+00
      go to 40

    end if

    if ( ka == 0 ) then
      go to 60
    end if

    dst = w(dstsav)
    alphak = abs ( v(stppar) )
    phi = dst - rad
    t = v(dgnorm) / rad
!
!  Smaller radius.
!
    if ( rad <= v(rad0) ) then

      uk = t - w(emin)
      lk = 0.0E+00
      if ( 0.0E+00 < alphak ) then
        lk = w(lk0)
      end if
      lk = max ( lk, t - w(emax) )
      if ( 0.0E+00 < v(dst0) ) then
        lk = max ( lk, ( v(dst0) - rad ) * w(phipin) )
      end if
!
!  Bigger radius.
!
    else

      uk = t - w(emin)

      if ( 0.0E+00 < alphak ) then
        uk = min ( uk, w(uk0) )
      end if

      lk = max ( 0.0E+00, -v(dst0), t - w(emax) )

      if ( 0.0E+00 < v(dst0) ) then
        lk = max ( lk, (v(dst0)-rad)*w(phipin) )
      end if

    end if

    go to 260

  end if
!
!  Fresh start.
!
  k = 0
  uk = -1.0E+00
  ka = 0
  kalim = 50
!
!  Store diagonal of DIHDI in W(DIAG0+1:DIAG0+P).
!
  j = 0
  do i = 1, p
    j = j + i
    k1 = diag0 + i
    w(k1) = dihdi(j)
  end do
!
!  Determine W(DGGDMX), the largest element of DIHDI.
!
  t1 = 0.0E+00
  j = p * (p + 1) / 2
  do i = 1, j
    t = abs(dihdi(i))
    t1 = max ( t1, t )
  end do
  w(dggdmx) = t1
!
!  Try ALPHA = 0.
!
40 continue

  call lsqrt ( 1, p, l, dihdi, irc )
!
!  Indefinite H.  Underestimate smallest eigenvalue, use this
!  estimate to initialize lower bound LK on ALPHA.
!
  if ( irc == 0 ) then
    go to 60
  end if

  j = ( irc * ( irc + 1 ) ) / 2
  t = l(j)
  l(j) = 1.0E+00
  w(1:irc) = 0.0E+00
  w(irc) = 1.0E+00
  call litvmu ( irc, w, l, w )
  t1 = v2norm ( irc, w )
  lk = -t / t1 / t1
  v(dst0) = -lk

  if ( restrt ) then
    go to 210
  end if

  v(nreduc) = 0.0E+00
  go to 70
!
!  Positive definite H.  Compute unmodified Newton step.
!
60 continue

  lk = 0.0E+00
  call livmul ( p, w(q), l, dig )
  v(nreduc) = 0.5E+00 * 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 <= phimax ) then
    alphak = 0.0E+00
    go to 290
  end if

  if ( restrt ) then
    go to 210
  end if
!
!  Prepare to compute Gerschgorin estimates of largest and
!  smallest eigenvalues.
!
70 continue

  v(dgnorm) = v2norm ( p, dig )

  if ( v(dgnorm) == 0.0E+00 ) then
    v(stppar) = 0.0E+00
    v(preduc) = 0.0E+00
    v(dstnrm) = 0.0E+00
    v(gtstep) = 0.0E+00
    step(1:p) = 0.0E+00
    return
  end if

  k = 0
  do i = 1, p
    wi = 0.0E+00
    do j = 1, i - 1
      k = k + 1
      t = abs ( dihdi(k) )
      wi = wi + t
      w(j) = w(j) + t
    end do
    w(i) = wi
    k = k + 1
  end do
!
!  Underestimate smallest eigenvalue of inverse(D)*H*inverse(D).
!
  k = 1
  t1 = w(diag) - w(1)

  do i = 2, p
    j = diag0 + i
    t = w(j) - w(i)
    if ( t < t1 ) then
      t1 = t
      k = i
    end if
  end do

  sk = w(k)
  j = diag0 + k
  akk = w(j)
  k1 = ( k * ( k - 1 ) ) / 2 + 1
  inc = 1
  t = 0.0E+00

  do i = 1, p

    if ( i == k ) then
      inc = i
      k1 = k1 + inc
    else
      aki = abs(dihdi(k1))
      si = w(i)
      j = diag0 + i
      t1 = 0.5E+00 * (akk - w(j) + si - aki)
      t1 = t1 + sqrt(t1*t1 + sk*aki)

      t = max ( t, t1 )

      if ( k <= i ) then
        inc = i
      end if

      k1 = k1 + inc

    end if

  end do

  w(emin) = akk - t
  uk = v(dgnorm) / rad - w(emin)
!
!  Compute Gerschgorin overestimate of largest eigenvalue.
!
  k = 1
  t1 = w(diag) + w(1)

  do i = 2, p
    j = diag0 + i
    t = w(j) + w(i)
    if ( t1 < t ) then
      t1 = t
      k = i
    end if
  end do

  sk = w(k)
  j = diag0 + k
  akk = w(j)
  k1 = ( k * ( k - 1 ) ) / 2 + 1
  inc = 1
  t = 0.0E+00

  do i = 1, p

    if ( i == k ) then

      inc = i
      k1 = k1 + inc

    else

      aki = abs ( dihdi(k1) )
      si = w(i)
      j = diag0 + i
      t1 = 0.5E+00 * ( w(j) + si - aki - akk )
      t1 = t1 + sqrt ( t1 * t1 + sk * aki )
      t = max ( t, t1 )

      if ( k <= i ) then
        inc = i
      end if

      k1 = k1 + inc

    end if

  end do

  w(emax) = akk + t
  lk = max ( lk, v(dgnorm) / rad - w(emax) )
!
!  ALPHAK = current value of ALPHA.  We
!  use More's scheme for initializing it.
!
  alphak = abs ( v(stppar) ) * v(rad0) / rad
!
!  Compute L0 for positive definite H.
!
  if ( irc == 0 ) then

    call livmul ( p, w, l, w(q) )
    t = v2norm ( p, w )
    w(phipin) = dst / t / t
    lk = max ( lk, phi * w(phipin) )

  end if
!
!  Safeguard ALPHAK and add ALPHAK*IDENTITY to inverse(D)*H*inverse(D).
!
210 continue

  ka = ka + 1

  if ( alphak <= -v(dst0) .or. alphak < lk .or. uk <= alphak ) then
    alphak = uk * max ( 0.001E+00, sqrt ( lk / uk ) )
  end if

  k = 0
  do i = 1, p
    k = k + i
    j = diag0 + i
    dihdi(k) = w(j) + alphak
  end do
!
!  Try computing Cholesky decomposition.
!
  call lsqrt ( 1, p, l, dihdi, irc )
!
!  inverse(D)*H*inverse(D) + ALPHAK*IDENTITY  is indefinite.  Overestimate
!  smallest eigenvalue for use in updating LK.
!
  if ( irc /= 0 ) then

    j = ( irc * ( irc + 1 ) ) / 2
    t = l(j)
    l(j) = 1.0E+00
    w(1:irc) = 0.0E+00
    w(irc) = 1.0E+00
    call litvmu ( irc, w, l, w )
    t1 = v2norm ( irc, w )
    lk = alphak - t / t1 / t1
    v(dst0) = -lk
    go to 210

  end if
!
!  ALPHAK makes inverse(D)*H*inverse(D) positive definite.
!  Compute Q = -D * STEP, check for convergence.
!
  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 <= phimax .and. phimin <= phi ) then
    go to 290
  end if

  if ( phi == oldphi ) then
    go to 290
  end if

  oldphi = phi

  if ( 0.0E+00 < phi ) then
    go to 260
  end if
!
!  Check for the special case of H + ALPHA*D**2  (nearly)
!  singular.  delta is >= the smallest eigenvalue of
!  inverse(D)*H*inverse(D) + ALPHAK*IDENTITY.
!
  if ( 0.0E+00 < v(dst0) ) then
    go to 260
  end if

  delta = alphak + v(dst0)
  twopsi = alphak * dst * dst + dotprd ( p, dig, w(q) )

  if ( delta < psifac * twopsi ) then
    go to 270
  end if
!
!  Unacceptable ALPHAK.  Update LK, UK, ALPHAK.
!
260 continue

  if ( kalim <= ka ) then
    go to 290
  end if

  call livmul ( p, w, l, w(q) )
  t1 = v2norm ( p, w )
!
!  The following min is necessary because of restarts.
!
  if ( phi < 0.0E+00 ) then
    uk = min ( uk, alphak )
  end if

  alphak = alphak + ( phi / t1 ) * ( dst / t1 ) * ( dst / rad )
  lk = max ( lk, alphak )
  go to 210
!
!  Decide how to handle nearly singular H + ALPHA*D**2.
!
!  If not yet available, obtain machine dependent value dgxfac.
!
270 continue

  if ( dgxfac == 0.0E+00 ) then
    dgxfac = epsfac * epsilon ( dgxfac )
  end if
!
!  Is DELTA so small we cannot handle the special case in
!  the available arithmetic?  If so, accept STEP as it is.
!
  if ( dgxfac * w(dggdmx) < delta ) then
!
!  Handle nearly singular H + ALPHA*D**2.
!  Negate ALPHAK to indicate special case.
!
    alphak = -alphak
!
!  Allocate storage for scratch vector X.
!
    x0 = q0 + p
    x = x0 + 1
!
!  Use inverse power method with start from LSVMIN to obtain
!  approximate eigenvector corresponding to smallest eigenvalue
!  of inverse ( D ) * H * inverse ( D ).
!
    delta = kappa * delta
    t = lsvmin ( p, l, w(x), w )
    k = 0
!
!  Normalize W.
!
    do

      w(1:p) = t * w(1:p)
!
!  Complete current inverse power iteration.
!  Replace W by inverse ( L' ) * W.
!
      call litvmu ( p, w, l, w )
      t1 = 1.0E+00 / v2norm ( p, w )
      t = t1 * t

      if ( t <= delta ) then
        exit
      end if

      if ( 30 < k ) then
        go to 290
      end if

      k = k + 1
!
!  Start next inverse power iteration by storing normalized W in X.
!
      do i = 1, p
        j = x0 + i
        w(j) = t1 * w(i)
      end do
!
!  Compute W = inverse ( L ) * X.
!
      call livmul ( p, w, l, w(x) )
      t = 1.0E+00 / v2norm ( p, w )

    end do

    w(1:p) = t1 * w(1:p)
!
!  Now W is the desired approximate unit eigenvector and
!  T * X = ( inverse(D) * H * inverse(D) + ALPHAK * I ) * W.
!
    sw = dotprd ( p, w(q), w )
    t1 = ( rad + dst ) * ( rad - dst )
    root = sqrt ( sw * sw + t1 )
    if ( sw < 0.0E+00 ) then
      root = -root
    end if
    si = t1 / (sw + root)
!
!  Accept current step if adding SI * W would lead to a
!  further relative reduction in PSI of less than V(EPSLON) / 3.
!
    v(preduc) = 0.5E+00 * twopsi
    t1 = 0.0E+00
    t = si * ( alphak * sw &
      - 0.5E+00 * si * ( alphak + t * dotprd ( p, w(x), w ) ) )

    if ( epso6 * twopsi <= t ) then
      v(preduc) = v(preduc) + t
      dst = rad
      t1 = -si
    end if

    do i = 1, p
      j = q0 + i
      w(j) = t1 * w(i) - w(j)
      step(i) = w(j) / d(i)
    end do

    v(gtstep) = dotprd ( p, dig, w(q) )
!
!  Save values for use in a possible restart.
!
    v(dstnrm) = dst
    v(stppar) = alphak
    w(lk0) = lk
    w(uk0) = uk
    v(rad0) = rad
    w(dstsav) = dst
!
!  Restore diagonal of DIHDI.
!
    j = 0
    do i = 1, p
      j = j + i
      k = diag0 + i
      dihdi(j) = w(k)
    end do

    return

  end if
!
!  Successful step.  Compute STEP = - inverse ( D ) * Q.
!
290 continue

  do i = 1, p
    j = q0 + i
    step(i) = -w(j) / d(i)
  end do
  v(gtstep) = -dotprd ( p, dig, w(q) )
  v(preduc) = 0.5E+00 * ( abs ( alphak ) *dst*dst - v(gtstep))
!
!  Save values for use in a possible restart.
!
  v(dstnrm) = dst
  v(stppar) = alphak
  w(lk0) = lk
  w(uk0) = uk
  v(rad0) = rad
  w(dstsav) = dst
!
!  Restore diagonal of DIHDI.
!
  j = 0
  do i = 1, p
    j = j + i
    k = diag0 + i
    dihdi(j) = w(k)
  end do

  return
end
subroutine hipass ( y, n, fc, k, hhp, yf, nyf )

!*****************************************************************************80
!
!! HIPASS carries out a high-pass filtering of a series.
!
!  Discussion:
!
!    This routine carries out hi-pass filtering of the
!    series.  the filter is the k-term
!    least squares approximation to the cutoff filter
!    with cutof frequency fc.  its transfer function
!    has a transition band of width delta surrounding fc,
!    where delta = 4*pi/k.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical err01, err02, err03, err04, err05
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real fc
!        the user supplied cutoff frequency.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     real hhp(k)
!        the array in which the -ideal- high pass filter coefficients
!        will be returned.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer k
!        the number of filter terms to be computed.
!     character*1 lfc(8), lk(8), ln(8)
!        the arrays containing the names of the variables fc, k and n.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  implicit none

  real fc
  integer k
  integer n
  integer nyf
!
!  array arguments
  real &
     hhp(*),y(*),yf(*)
!
!  scalars in common
  integer &
     ierr

  logical &
     err01,err02,err03,err04,err05,head
!
!  local arrays
  character &
     lfc(8)*1,lk(8)*1,ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,eisii,eriodd,ersii,erslfs,fltsl,hpflt,lpflt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.
!
!  call error checking routines
!
  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  call ersii(nmsub, lfc, fc, 0.0e0, &
             0.5e0, 2, head, err02, lfc, lfc)

  call eisii(nmsub, lk, k, 1, n, 2, head, err03, lk, lk)

  call eriodd(nmsub, lk, k, 1, head, err04)

  if ( err01 .or. err02 .or. err03 .or. err04 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call erslfs(nmsub, fc, k, head, err05)

  if ( err05 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call lpflt (fc, k, hhp)

  call hpflt (hhp, k, hhp)

  call fltsl (y, n, k, hhp, yf, nyf)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call hipass (y, n, fc, k, hhp, yf, nyf)')
end
subroutine histc ( y, n, ncell, ylb, yub, ldstak )

!*****************************************************************************80
!
!! HISTC: long call for producing a histogram.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idp
!        the code value for double precision for framework.
!     integer ierr
!        the code indicating whether or not an error has
!        been discovered.  0 means no error, not 0 means
!        some error exists.
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer iint
!        the code value for integer for framework
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        input parameter.  the number of double precision
!        elements dimensioned for dstak in the user program.
!     integer lsort
!        the starting location in istak of the permutation
!        vector.
!     integer n
!        input parameter.  the length of y.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     integer ncell
!        the user supplied value for the number of cells in the
!        histogram.  if ncell is less than or equal to zero, the
!        number of cells to be used (ncells) will be calculated from
!        the number of observations.
!     integer ncells
!        the number of cells in the histogram.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real y(n)
!        input parameter.  the vector of data points on which
!        the statistics are computed.  y is sorted, but restored
!        to its original order afterwards.
!     integer ydist
!        the starting location in rstak of the distribution vector.
!     real ylb
!        the lower bound for selecting data from y for the histogram.
!     real yub
!        the upper bound for selecting data from y for the histogram.
!
  implicit none

  real &
     ylb,yub
  integer &
     ldstak,n,ncell
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     idp,ifp,iint,lsort,nall0,ncells,ydist
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external hster,hstmn,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!     initialize name vectors
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       'h',      'i',      's',      't',      'c',      ' '/

  data idp /4/
  data iint /2/
!
!  compute ncells
!
  if ((ncell <= 0) .and. (n >= 1)) then
     ncells = min(nint(5.5e0+1.5e0*anint(log10(real(n)))),25)
  else
     ncells = ncell
  end if
!
!  check for errors in the input parameters
!
  call hster(nmsub, y, n, ncells, ldstak, ylb, yub, ierr)
!
!  print error message.
!
  if (ierr /= 0) then
    write ( *,1000)
    return
  end if
!
!  set up framework area.
!
  call stkset (ldstak, idp)
  nall0 = stkst(1)
!
!  set up work vectors
!
  ifp = 3

  lsort = stkget(n,iint)
  ydist = stkget(ncells,ifp)
!
!  compute the histogram.
!
  call hstmn(y, n, ncells, ylb, yub, istak(lsort), rstak(ydist))
!
!  return the work vectors.
!
  call stkclr(nall0)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call histc (y, n, ncell, ylb, yub, ldstak)')
end
subroutine hist ( y, n, ldstak )

!*****************************************************************************80
!
!! HIST: short call for producing a histogram.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idp
!        the code value for double precision for framework.
!     integer ierr
!        the code indicating whether or not an error has
!        been discovered.  0 means no error, not 0 means
!        some error exists.
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer iint
!        the code value for integer for framework
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        input parameter.  the number of double precision
!        elements dimensioned for dstak in the user program.
!     integer lsort
!        the starting location in istak of the permutation
!        vector.
!     integer n
!        input parameter.  the length of y.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     integer ncells
!        the number of cells in the histogram.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real y(n)
!        input parameter.  the vector of data points on which
!        the statistics are computed.  y is sorted, but restored
!        to its original order afterwards.
!     integer ydist
!        the starting location in rstak of the distribution vector.
!     real ylb
!        the lower bound for selecting data from y for the histogram.
!     real yub
!        the upper bound for selecting data from y for the histogram.
!
  implicit none

  integer &
     ldstak,n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     ylb,yub
  integer &
     idp,ifp,iint,lsort,nall0,ncells,ydist
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external hster,hstmn,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!     initialize name vectors
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       'h',      'i',      's',      't',      ' ',      ' '/

  data idp /4/
  data iint /2/
  data ylb/0.0e0/, yub/0.0e0/
!
!  compute ncells
!
  if (n >= 1) then
     ncells = min(nint(5.5e0+1.5e0*anint(log10(real(n)))),25)
  else
     ncells = 1
  end if
!
!  check for errors in the input parameters
!
  call hster(nmsub, y, n, ncells, ldstak, ylb, yub, ierr)
!
!  print error message.
!
  if (ierr /= 0) then
    write ( *,1000)
    return
  end if
!
!  set up framework area.
!
  call stkset (ldstak, idp)
  nall0 = stkst(1)
!
!  set up work vectors
!
  ifp = 3

  lsort = stkget(n,iint)
  ydist = stkget(ncells,ifp)
!
!  compute the histogram.
!
  call hstmn(y, n, ncells, ylb, yub, istak(lsort), rstak(ydist))
!
!  return the work vectors.
!
  call stkclr(nall0)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call hist (y, n, ldstak)')
end
subroutine hpcoef ( hlp, k, hhp )

!*****************************************************************************80
!
!! HPCOEF computes hi-pass filter given K-term low pass filter coefficients.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     real hhp(k)
!        the array in which the high pass filter coefficients
!        will be returned.
!     real hlp(k)
!        the array in which the input low pass filter coefficients
!        are stored.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer k
!        the number of filter terms to be computed.
!     character*1 lhlp(8), lk(8)
!        the arrays containing the names of the variables hlp and k.
!     character*1 nmsub(6)
!        the array containing the name of this routine.
  implicit none

  integer &
     k
!
!  array arguments
  real &
     hhp(*),hlp(*)
!
!  scalars in common
  integer &
     ierr

  logical &
     err01,err02,err03,head
!
!  local arrays
  character &
     lhlp(8)*1,lk(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,eriodd,erslf,hpflt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, lk, k, 1, 1, head, err01, lk)

  call eriodd(nmsub, lk, k, 1, head, err02)

  if (err01 .or. err02) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call erslf(nmsub, lhlp, k, hlp, head, err03)

  if (err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call hpflt (hlp, k, hhp)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call hpcoef (hlp, k, hhp)')
end
subroutine hpflt ( hlp, k, hhp )

!*****************************************************************************80
!
!! HPFLT compute high pass filter coefficients corresponding to low pass filter.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real hhp(k)
!        the array in which the high pass filter coefficients
!        will be returned.
!     real hlp(k)
!        the array in which the input low pass filter coefficients
!        are stored.
!     integer i
!       an index variable.
!     integer k
!        the number of filter terms to be computed.
!     integer kmid
!        the midpoint of the filter.
!
  implicit none

  integer &
     k
!
!  array arguments
  real &
     hhp(k),hlp(k)

  integer kmid

  hhp(1:k) = -hlp(1:k)

  kmid = (k + 1) / 2

  hhp(kmid) = hhp(kmid) + 1.0e0

  return
end
subroutine hster ( nmsub, y, n, ncells, ldstak, ylb, yub, ierr )

!*****************************************************************************80
!
!! HSTER does error checking for the HIST family of histogram routines.
!
!  Discussion:
!
!    This routine checks input parameters to the user
!    callable members of the hist family of routines
!    for errors and reports any that it finds, besides
!    returning a flag indicating that errors have been found.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        output parameter.  a flag indicating whether or
!        not an error has been found.  0 = ok, 1 = error.
!     logical ier1
!        true if n < 3
!     logical ier2
!        true if ldstak < (n + 13)/2.
!     logical ier3
!        true if all y values are equal.
!     logical ier4
!        true if no data within user limits
!     integer ldsmin
!        minimum length of framework area in double
!        precision elements.
!     integer ldstak
!        input parameter.  the number of locations provided in
!        the framework area.
!     character*1 llds(8), ln(8), lone(8), ly(8)
!        the array(s) containing the name(s) fo the varialbe(s) checked
!        for errors
!     integer n
!        input parameter.  the number of elements in y.
!     integer ncells
!        the number of cells in the histogram.
!     character*1 nmsub(6)
!        the name of the calling subroutine
!     integer nv
!        the number of values outside user supplied limits.
!     real y(n)
!        input parameter.  the vector of n observations.
!     real ylb
!        the lower bound for selecting data from y for the histogram.
!     real yub
!        the upper bound for selecting data from y for the histogram.
!
  implicit none

  logical head
  logical ier1
  logical ier2
  logical ier4
  integer ierr
  integer ldstak
  integer n
  integer ncells
  character nmsub(6)
  real y(*)
  real ylb
  real yub
!
!
  integer &
     ldsmin,nv
!
!  local arrays
  character &
     llds(8)*1,ln(8)*1,lone(8)*1,ly(8)*1
!
!  external subroutines
  external eisge,ldscmp
!
!     initialize name vectors
!
  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', ' ', ' ', ' ', ' ', ' ', ' ', ' '/

  ier1 = .false.
  ier2 = .false.
  ier4 = .false.

  ierr = 0

  head = .true.
!
!  check to see that there is at least one data points.
!
  call eisge ( nmsub, ln, n, 1, 2, head, ier1, lone )

  if ( ier1 ) then
    ierr = 1
    return
  end if
!
!  check for sufficient work area
!
  call ldscmp(2, 0, n, 0, 0, 0, 's', ncells, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, ier2, llds)

  if ( ier2 ) then
    ierr = 1
    return
  end if
!
!  Is any data between user supplied limits?
!
  if ( ylb < yub  .and. 1 <= n ) then
    call ervii ( nmsub, ly, y, n, ylb, yub, n-1, head, 1, nv, ier4 )
    if ( ier4 ) then
      ierr = 1
    end if
  end if

  return
end
subroutine hstmn ( y, n, ncells, ylb, yub, lsort, ydist )

!*****************************************************************************80
!
!! HSTMN is the main routine for producing histograms.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real a(6)
!        a vector used for printing the histogram scale.
!     real alpha
!        the percentage to be trimmed off each end of y for the
!        trimmed means calculations.
!     real b1sqrt
!        beta one  -  a measure of skewness
!     real b2
!        beta two  -  a measure of kurtosis
!     real cfract
!        the cumulative distribution
!     real cfrctm
!        the reverse cumulative distribution
!     real cntmx
!        the size of the largest cell count
!     real fract
!        the fraction of the observations in a given cell
!     integer iflag
!        if 1, then more than 50 obs. fell in a single cell,
!        and a scaled histogram will be provided.
!     character*1 iplus
!        the character +
!     integer lsort(n)
!        the permutation vector.
!     integer mid
!        the index of the (an) element of y closest to zero, when
!        y has been sorted.
!     integer n
!        input parameter.  the length of y.
!     integer ncells
!        the number of cells in the frequency distribution.
!     integer nhigh
!        the index of the largest value in the sorted array
!        to be used in the histogram
!     integer nlow
!        the index of the smallest value in the sorted array
!        to be used in the histogram
!     integer nobs
!        the number of observations actually used in the histogram
!     integer num
!        the cell count
!     integer nums
!        the scaled cell count
!     real p
!        a variable used to determine the scale
!     real scale
!        the printed increment on the histogram scale
!     real sumda
!        the sum of the absolute differences from the mean.
!     real sumd2
!        the sum of the squares of the differences.
!     real sumd3
!        the sum of the cubes of the differences.
!     real sumd4
!        the sum of the 4th powers of the differences.
!     real sumt1
!        the sum of the alpha trimmed array y.
!     real sum1, sum2, sum3
!        various sums of the data.
!     real temp
!        a temporary storage variable
!     real width
!        the width of a cell
!     real xn
!        the foating point representation of n
!     real xnn
!        the unrounded number of plotting posistions on a scales
!        histogram
!     real y(n)
!        input parameter.  the vector of data points on which
!        the statistics are computed.  y is sorted, but restored
!        to its original order afterwards.
!     real ydist(ncells)
!        the frequency distribution used to create the histogram.
!     real yintmp
!        the midpoint of the ith cell
!     real ylb
!        the lower bound for selecting data from y for the histogram.
!     real ymax
!        the histogram upper bound used
!     real ymddsd
!        the mean absolute deviation / the standard deviation
!     real ymean, ymeant
!        the mean of the observations used in the histogram
!     real ymed
!        the median of the observations used in the histogram
!     real ymidrg
!        the mid range of the observations used in the histogram
!     real ymin
!        the histogram lower bound used.
!     real yrange
!        the range of the observations used in the histogram
!     real ysd
!        the standard deviation of the observations used in the
!        histogram.
!     real yub
!        the upper bound for selecting data from y for the histogram.
!     real yvar
!        the variance of the observations.
!
  implicit none

  real &
     ylb,yub
  integer &
     n,ncells
!
!  array arguments
  real &
     y(n),ydist(ncells)
  integer &
     lsort(n)

  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,j,mid,nhigh,nlow,nobs,num,nums
  character &
     iplus*1
!
!  local arrays
  real &
     a(6)
!
!  external subroutines
  external geni,srtir,srtri,stat1,sumbs,sumds,sumss,sumts, &
     versp

  data iplus /'+'/
  data alpha/0.25e0/

!
!  sort data
!
  call geni(lsort, n, 1, 1)
  call srtir(lsort, n, y)
!
!  fix upper and lower bounds.
!
  nlow = 1
  nhigh = n
  if ( ylb /= yub ) then
!
!  find index of the first value of y  >=  ylb
!
    do i=1,n
      if ( ylb <= y(i) ) then
        nlow = i
        exit
      end if
    end do
!
!  find index of the last value of y <= yub
!
    do i=1,n
      j = n - i + 1
      if (y(j) <= yub) then
        nhigh = j
        exit
      end if
    end do

  end if

  xn = real ( nhigh-nlow+1 )
  nobs = nhigh - nlow + 1
!
!  compute median, extrema, mid-range, range and frequency
!  distribution for ncells cells
!
  call stat1(y(nlow), nobs, ymed, ymin, ymax, ymidrg, yrange, &
     ncells, ylb, yub, ydist)

  if ( ylb < yub ) then
    ymin = ylb
    ymax = yub
  end if
!
!  compute mean, trimmed mean, standard deviation,
!  mean deviation/standard deviation, beta one, and beta two
!
  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)

  yvar = 0.0e0
  ysd = 0.0e0
  b1sqrt = 0.0e0
  b2 = 0.0e0
  ymddsd = 0.0e0

  if ( 0.0 < sumd2  .and. 1 < nobs ) then

    yvar = sumd2 / real  ( nobs - 1 )
    ysd = sqrt(yvar)
    b1sqrt = abs((sumd3/xn)/((sumd2/xn)**1.5e0))
    b2 = (sumd4/xn)/((sumd2/xn)**2)
    ymddsd = sumda/(ysd* real ( nobs ) )

  end if
!
!  output statistics
!
  call versp(.true.)
  write ( *,1070) n, y(nlow), y(nhigh), ymin, ymax
  write ( *,1000) &
     ncells, nobs, ymeant, y(nlow), ysd, y(nhigh), ymddsd, &
     ymean, b1sqrt, ymed, b2
  write ( *,1010)
!
!  check for more than 50 values in interval and find max. value.
!
  iflag = 0
  cntmx = 0.0e0
  do i=1,ncells
     if (ydist(i) > cntmx) cntmx = ydist(i)
  end do

  if (nint(cntmx) > 50) iflag = 1
!
!  determine scale.
!
  if (iflag == 0) then
     scale = 1.0e0
  else
     p = cntmx/xn
     scale = 0.05e0
     if (p > 0.25e0) scale = 0.1e0
     if (p > 0.5e0) scale = 0.2e0
  end if
!
!  print column headings and histogram scale.
!
  if (iflag == 0) write ( *,1020)
  if (iflag /= 0) write ( *,1080)
  write ( *,1090)

  if ( iflag == 0 ) then
    write ( *,1030) (i,i=10,50,10)
  else
    a(1) = 0.0e0
    do i=1,5
      a(i+1) = a(i) + scale
    end do
    write ( *,1040) (a(i),i=1,6)
  end if

  write ( *,1050)
  cfract = 0.0e0
  cfrctm = 1.0e0
  temp = 0.0e0
  width = (ymax-ymin)/ real ( ncells )
  yintmp = ymin
  yintmp = yintmp - width/2.0e0

  do i=1,ncells

     num = int(ydist(i)+0.5e0)

     if (mod(ncells,2) == 1 .and. i == ncells/2+1 &
         .and. ymin == (-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 <= 0) then
       write ( *,1060) yintmp, cfract, cfrctm, fract, num
     else
       if (iflag == 0) then
         nums = num
       else
         xnn = fract*10.0e0/scale
         nums = int(xnn)
         nums = max(1, nums + int(xnn-real ( nums ) +0.5e0))
       end if
       write ( *,1060) yintmp, cfract, cfrctm, fract, &
          num, (iplus,j=1,nums)
     end if

  end do
!
!  restore data to original order
!
  call srtri(y, n, lsort)

  return

 1000 format(/' number of cells        = ', i15/ &
          ' observations used      = ', i15, 11x, &
                '25 pct trimmed mean = ', 1pe15.8/ &
          ' min. observation used  = ', e15.8, 11x, &
                'standard deviation  = ', e15.8/ &
          ' max. observation used  = ', e15.8, 11x, &
                'mean dev./std. dev. = ', e15.8/ &
          ' mean value             = ', e15.8, 11x, &
                'sqrt(beta one)      = ', e15.8/ &
          ' median value           = ', e15.8, 11x, &
                'beta two            = ', e15.8)
 1010 format(//' for a normal distribution, the values (mean', &
     ' deviation/standard deviation), sqrt(beta one), and beta', &
     ' two are approximately'/ &
     ' 0.8, 0.0 and 3.0, respectively.  to test the ', &
     'null hypothesis of normality, see tables of critical values', &
     ' pp. 207-208,'/  ' biometrika tables for', &
     ' statisticians, vol. 1.  see pp. 67-68 for a discussion of', &
     ' these tests.')
 1020 format(///5x,'hinterval     cum.   1-cum.   cell   no.',19x, &
   'number of observations')
 1030 format('+',47x,'0',8x,5(i2,8x))
 1040 format('+',46x,6(f4.2,6x))
 1050 format(4x,42('-'),2x,'+',5('---------+'))
 1060 format(3x,1pe13.6,2x,2(0pf5.3,3x),f5.3,1x,i5,4x,50a1)
 1070 format (' histogram'// &
          ' number of observations = ', i15/ &
          ' minimum observation    = ', 1pe15.8/ &
          ' maximum observation    = ', e15.8// &
          ' histogram lower bound  = ', e15.8/ &
          ' histogram upper bound  = ', e15.8)
 1080 format(///5x,'hinterval     cum.   1-cum.   cell   no.',23x, &
   'cell fraction')
 1090 format(5x,'hmid point   fract.  fract.  fract.  obs.' )
end
function i1mach ( i )

!*****************************************************************************80
!
!! I1MACH returns integer machine constants.
!
!  Discussion:
!
!    Input/output unit numbers.
!
!      I1MACH(1) = the standard input unit.
!      I1MACH(2) = the standard output unit.
!      I1MACH(3) = the standard punch unit.
!      I1MACH(4) = the standard error message unit.
!
!    Words.
!
!      I1MACH(5) = the number of bits per integer storage unit.
!      I1MACH(6) = the number of characters per integer storage unit.
!
!    Integers.
!
!    Assume integers are represented in the S digit base A form:
!
!      Sign * (X(S-1)*A**(S-1) + ... + X(1)*A + X(0))
!
!    where 0 <= X(1:S-1) < A.
!
!      I1MACH(7) = A, the base.
!      I1MACH(8) = S, the number of base A digits.
!      I1MACH(9) = A**S-1, the largest integer.
!
!    Floating point numbers
!
!    Assume floating point numbers are represented in the T digit 
!    base B form:
!
!      Sign * (B**E) * ((X(1)/B) + ... + (X(T)/B**T) )
!
!    where 0 <= X(I) < B for I=1 to T, 0 < X(1) and EMIN <= E <= EMAX.
!
!      I1MACH(10) = B, the base.
!
!    Single precision
!
!      I1MACH(11) = T, the number of base B digits.
!      I1MACH(12) = EMIN, the smallest exponent E.
!      I1MACH(13) = EMAX, the largest exponent E.
!
!    Double precision
!
!      I1MACH(14) = T, the number of base B digits.
!      I1MACH(15) = EMIN, the smallest exponent E.
!      I1MACH(16) = EMAX, the largest exponent E.
!
!  Modified:
!
!    24 April 2007
!
!  Author:
!
!    Phyllis Fox, Andrew Hall, Norman Schryer
!
!  Reference:
!
!    Phyllis Fox, Andrew Hall, Norman Schryer,
!    Algorithm 528,
!    Framework for a Portable Library,
!    ACM Transactions on Mathematical Software,
!    Volume 4, Number 2, June 1978, page 176-188.
!
!  Parameters:
!
!    Input, integer I, chooses the parameter to be returned.
!    1 <= I <= 16.
!
!    Output, integer I1MACH, the value of the chosen parameter.
!
  implicit none

  integer i
  integer i1mach

  if ( i < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'I1MACH - Fatal error!'
    write ( *, '(a)' ) '  The input argument I is out of bounds.'
    write ( *, '(a)' ) '  Legal values satisfy 1 <= I <= 16.'
    write ( *, '(a,i12)' ) '  I = ', i
    i1mach = 0
    stop
  else if ( i == 1 ) then
    i1mach = 5
  else if ( i == 2 ) then
    i1mach = 6
  else if ( i == 3 ) then
    i1mach = 7
  else if ( i == 4 ) then
    i1mach = 6
  else if ( i == 5 ) then
    i1mach = 32
  else if ( i == 6 ) then
    i1mach = 4
  else if ( i == 7 ) then
    i1mach = 2
  else if ( i == 8 ) then
    i1mach = 31
  else if ( i == 9 ) then
    i1mach = 2147483647
  else if ( i == 10 ) then
    i1mach = 2
  else if ( i == 11 ) then
    i1mach = 24
  else if ( i == 12 ) then
    i1mach = -125
  else if ( i == 13 ) then
    i1mach = 128
  else if ( i == 14 ) then
    i1mach = 53
  else if ( i == 15 ) then
    i1mach = -1021
  else if ( i == 16 ) then
    i1mach = 1024
  else if ( 16 < i ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'I1MACH - Fatal error!'
    write ( *, '(a)' ) '  The input argument I is out of bounds.'
    write ( *, '(a)' ) '  Legal values satisfy 1 <= I <= 16.'
    write ( *, '(a,i12)' ) '  I = ', i
    i1mach = 0
    stop
  end if

  return
end
function i8save ( isw, ivalue, set )

!*****************************************************************************80
!
!! I8SAVE returns the current error number or recovery switch.
!
!  Discussion:
!
!    if (isw = 1) i8save returns the current error number and
!    sets it to ivalue if set = .true. .
!
!    if (isw = 2) i8save returns the current recovery switch and
!    sets it to ivalue if set = .true. .
!
  implicit none

  integer i8save
  integer isw
  integer ivalue
  integer lerror
  integer lrecov
  logical set
!
!  local arrays
  integer iparam(2)
!
!  equivalences
  equivalence (iparam(1),lerror), (iparam(2),lrecov)
!
!  start execution error free and with recovery turned off.
!
  data lerror/0/ , lrecov/2/

  i8save=iparam(isw)

  if (set) then
    iparam(isw)=ivalue
  end if

  return
end
function icnti ( iv, niv, i )

!*****************************************************************************80
!
!! ICNTI counts the number of occurences of a value in an integer vector.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        input parameter.  the integer to count occurences of.
!     integer iv(niv)
!        input parameter.  the vector in which to count.
!     integer j
!        loop parameter.
!     integer niv
!        input parameter.  the length of iv.
!
  implicit none

  integer i
  integer icnti
  integer niv
!
!  array arguments
  integer &
     iv(niv)

  integer &
     j

  icnti = 0
  do j = 1, niv
     if (iv(j) == i) icnti = icnti + 1
  end do

  return
end
subroutine icopy ( n, isx, incx, isy, incy )

!*****************************************************************************80
!
!! ICOPY copies an integer vector.
!
!  Discussion:
!
!    This routine is a adaptation of the blas subroutine scopy,
!    modified to handle integer arrays.
!
!    copy integer isx to integer isy.
!    for i = 0 to n-1, copy  isx(lx+i*incx) to isy(ly+i*incy),
!    where lx = 1 if incx  >=  0, else lx = (-incx)*n, and ly is
!    defined in a similar way using incy.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an indexing variable.
!     integer incx, incy
!        the increment used for the copy from one variable to the other.
!     integer isx(n)
!        the array to be copied from.
!     integer isy(n)
!        the array to be copied to.
!     integer ix, iy
!        index variables.
!     integer m
!        the value of n modulo 7.
!     integer mp1
!        the value of m + 1.
!     integer n
!        the number of observations in the arrays isx and isy.
!     integer ns
!        the value of n * incx.
!
  implicit none

  integer n

  integer incx
  integer incy

  integer &
     isx(n),isy(n)
!
!
  integer &
     i,ix,iy,m,ns

  if(n <= 0)return
  if(incx == incy) if(incx-1) 5,20,60
    5 continue
!
!  code for unequal or nonpositive increments.
!
  ix = 1
  iy = 1
  if(incx<0)ix = (-n+1)*incx + 1
  if(incy<0)iy = (-n+1)*incy + 1
  do i = 1,n
    isy(iy) = isx(ix)
    ix = ix + incx
    iy = iy + incy
  end do

  return
!
!  code for both increments equal to 1
!
!  clean-up loop so remaining vector length is a multiple of 7.
!
   20 m = mod(n,7)
  if( m == 0 ) go to 40
  isy(1:m) = isx(1:m)
  if (  n < 7 ) then
    return
  end if

40 continue

  do i = m + 1, 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)
  end do

  return
!
!  code for equal, positive, nonunit increments.
!
   60 continue
  ns = n*incx
  do i=1,ns,incx
      isy(i) = isx(i)
  end do
  return
end
function imdcon ( k )

!*****************************************************************************80
!
!! IMDCON returns integer machine-dependent constants.
!
!  Discussion:
!
!    k = 1 means return standard output unit number.
!    k = 2 means return alternate output unit number.
!    k = 3 means return  input unit number.
!        (note -- k = 2, 3 are used only by test programs.)
!
  implicit none

  integer imdcon
  integer k

  integer &
     mdcon(3)
!
!  external functions
  integer &
     i1mach
  external i1mach

  mdcon(1) = i1mach(2)
  mdcon(2) = i1mach(3)
  mdcon(3) = i1mach(1)

  imdcon = mdcon(k)
  return
end
function inits ( os, nos, eta )

!*****************************************************************************80
!
!! INITS initializes an orthogonal series.
!
!  Discussion:
!
!    Initialize the orthogonal series so that inits is the number of terms
!    needed to insure the error is no larger than eta.  ordinarily, eta
!    will be chosen to be one-tenth machine precision.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!  Parameters:
!
!    os     array of nos coefficients in an orthogonal series.
!    nos    number of coefficients in os.
!    eta    requested accuracy of series.
!
  implicit none

  integer nos

  real eta
  integer inits
  real os(nos)

  real err
  integer i,ii

  if (nos<1) then
    call xerror ( 'inits   number of coefficients lt 1', 2, 2)
  end if

  err = 0.0

  do ii=1,nos

    i = nos + 1 - ii
    err = err + abs(os(i))

    if ( eta < err ) then
      exit
    end if

  end do

  if (i == nos) then
    call xerror ('inits   eta may be too small', 1, 2)
  end if

  inits = i

  return
end
function inperl ( )

!*****************************************************************************80
!
!! INPERL computes the number of elements that can be printed on one line.
!
!  Discussion:
!
!    This routine computes the number of vector elements that can
!    be printed in a line of output on the standard output file.
!
!    assumptions:
!
!    1) maximum width of line to use (imaxw) is 132.
!    2) number of characters not vector elements per line (iocpl) is 15.
!    3) width of field for an element, including spacing
!       between elements (iew) is 15.
!    4) maximum elements per line (imaxe) is 7.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iew
!        width of a field for printing out a vector element,
!        including spaces between adjacent elements.
!     integer imaxe
!        maximum number of array elements per line.
!     integer imaxw
!        maximum number of characters to allow per line.
!     integer iocpl
!        number of characters to be introduced to line in addition
!        to characters in the element fields.
!     integer iwidth
!        number of characters in a line on the standard output file.
!
  implicit none

  integer inperl

  integer &
     iew,imaxe,imaxw,iocpl,iwidth

!
!     initializations
!
  data iew /15/, imaxe /7/, imaxw /132/, iocpl /15/

  iwidth = 132
  inperl = (min(iwidth, imaxw) - iocpl)/iew
  inperl = min(inperl, imaxe)

  return
end
subroutine ipgdv ( per, nf, n, peri, freq, xaxis, yaxis, isym, lpcv, nprt )

!*****************************************************************************80
!
!! IPGDV produces coordinates for the spectral plots.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real freq(nf)
!        the array in which the frequencies at which the periodogram
!        was estimated are stored.
!     integer ispcer
!        an error indicator for the integrated periodogram computations.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer n
!        the actual number of observations in the series from which
!        the periodogram was computed.
!     integer nprt
!        the variable controling printed output, where
!        if nprt ==  0, the output is suppressed,
!        if nprt  >=   1, the output consists of a page plot.
!     integer nf
!        the number of frequencies for which the spectral estimates
!        are estimated.
!     integer npts
!        the number of x, y coordinates to be plotted.
!     real per(nf)
!        the raw periodogram.
!     real peri(nf)
!        the array containing the integrated periodogram values.
!     real xaxis(lpcv), yaxis(lpcv)
!        the x, y coordinates for the spectral plots.
!
  implicit none

  integer &
     lpcv,n,nf,nprt
!
!  array arguments
  real &
     freq(nf),per(nf),peri(nf),xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)
!
!
  integer &
     ispcer,npts
!
!  external subroutines
  external ipgmn,ipgord,ipgout

  call ipgmn(per, nf, peri, ispcer)
!
!  set coordinates for the integrated periodogram
!
  if (ispcer ==  0) then

    if (nprt == 0) return

    call ipgord(peri, nf, n, freq, xaxis, yaxis, isym, npts, lpcv)

  end if
!
!  plot the integrated periodogram
!
  call ipgout (xaxis, yaxis, isym, npts, lpcv, ispcer)

  return
end
subroutine ipgm ( yfft, n, lyfft, ldstak )

!*****************************************************************************80
!
!! IPGM: short call to compute the integrated periodogram of a series.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     integer freq
!        the starting location in the stack for
!        the array in which the frequencies corresponding to the
!        integrated spectrum values are stored.
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer iextnd
!        the indicator variable used to designate whether zero
!        (iextnd == 0) or the series mean (iextnd  /=  0) is to be
!        used to extend the series.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     character*1 llds(8), llyfft(8), ln(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations.
!     integer nall0
!        the number of outstanding allocations of the stack at the
!        time of this call.
!     integer nf
!        the number of frequencies at which the periodgram is
!        to be computed.
!     integer nfft
!        the effective length of the series to be transformed.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        the variable controling printed output, where
!        if nprt ==  0, the output is suppressed,
!        if nprt  >=   1, the output consists of a page plot.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer xaxis
!        the starting location in the stack for
!        the array in which the x axis values to be plotted are stored.
!     integer yaxis
!        the starting location in the stack for
!        the array in which the y axis values to be plotted are stored.
!     real yfft(lyfft)
!        the array containing the observed time series.
!
  implicit none

  integer &
     ldstak,lyfft,n
!
!  array arguments
  real &
     yfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     freq,iextnd,isym,ldsmin,lpcv,nall0,nf,nfft,nprt, &
     xaxis,yaxis
  logical &
     err01,err02,err03,head
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     llds(8)*1,llyfft(8)*1,ln(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external cntr,eisge,ipgdv,ldscmp,pgmmn,setesl,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  if (err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set length of extended series
!
  call setesl(n, 2, nfft)
  nf = nfft/2

  call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err02, llyfft)

  call ldscmp(3, 0, nf+103, 0, 0, 0, 's', 2*nfft+206, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds)

  if (err01 .or. err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set the size of the work area
!
  call stkset(ldstak, 4)
!
!  set the number of outstanding allocations.
!
  nall0 = stkst(1)

  lpcv = nf + 103
  nprt = 1
!
!  center the series
!
  call cntr(yfft, n, yfft)
  iextnd = 0
!
!  subdivide the stack.
!
  isym = stkget(lpcv, 2)
  xaxis = stkget(lpcv, 3)
  yaxis = stkget(lpcv, 3)

  freq = xaxis
!
!  compute the raw periodogram.
!
  call pgmmn (yfft, n, nfft, iextnd, nf, yfft, lyfft, rstak(yaxis), &
     rstak(freq), lpcv, 0, nmsub)
!
!  call the main driver for computing (and plotting) the integrated
!  periodogram.
!
  call ipgdv (yfft, nf, n, yfft, rstak(freq), rstak(xaxis), &
     rstak(yaxis), istak(isym), lpcv, nprt)

  call stkclr(nall0)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call ipgm (yfft, n, lyfft, ldstak)')
end
subroutine ipgmn ( per, nf, peri, ispcer )

!*****************************************************************************80
!
!! IPGMN computes the integrated periodogram.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer ispcer
!        an error indicator for the integrated periodogram computations.
!     integer nf
!        the number of frequencies at which the periodgram is
!        computed.
!     real per(nf)
!        the raw periodogram.
!     real peri(nf)
!        the array which contains the integrated periodogram.
!     real sm
!        a value used to compute the integrated periodogram estimates.
!
  implicit none

  integer &
     ispcer,nf
!
!  array arguments
  real &
     per(nf),peri(nf)

  real &
     sm
  integer &
     i

  sm = 0.0e0

  do i = 1, nf
     sm = sm + per(i)
     peri(i) = sm
  end do

  ispcer = 1
  if (sm == 0.0e0) return

  ispcer = 0

  peri(1:nf) = peri(1:nf) / sm

  return
end
subroutine ipgmp ( per, freq, nf, n, ldstak )

!*****************************************************************************80
!
!! IPGMP: user routine for integrated periodograms of a series (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real freq(nf)
!        the array in which the frequencies corresponding to the
!        integrated spectrum values are stored.
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer isym
!        ...
!     integer ldsmin
!        the minimum length allowed for dstak.
!     character*1 llds(8), ln(8), lnf(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer lpcv
!        ...
!     integer n
!        the actual number of observations in the series from which
!        the periodogram was computed.
!     integer nall0
!        the number of outstanding allocations of the stack at the
!        time of this call.
!     integer nf
!        the number of frequencies at which the periodgram is
!        to be computed.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        the variable controling printed output, where
!        if nprt ==  0, the output is suppressed,
!        if nprt  >=   1, the output consists of a page plot.
!     real per(nf)
!        the raw periodogram.
!     integer peri
!        the starting location in the stack for
!        the vector containing the integrated periodogram.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer xaxis
!        the starting location in the stack for
!        the array in which the x axis values to be plotted are stored.
!     integer yaxis
!        the starting location in the stack for
!        the array in which the y axis values to be plotted are stored.
!
  implicit none

  integer &
     ldstak,n,nf
!
!  array arguments
  real &
     freq(*),per(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer isym,ldsmin,lpcv,nall0,nprt,peri,xaxis,yaxis
  logical &
     err01,err02,err03,head
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     llds(8)*1,ln(8)*1,lnf(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external eisge,ipgdv,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  call eisge(nmsub, lnf, nf, (n+2)/2, 1, head, err02, lnf)

  if (err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call ldscmp(4, 0, nf+103, 0, 0, 0, 's', 3*nf+206, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds)

  if (err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set the size of the work area
!
  call stkset(ldstak, 4)
!
!  set the number of outstanding allocations.
!
  nall0 = stkst(1)

  lpcv = nf + 103
  nprt = 1
!
!  subdivide the stack.
!
  isym = stkget(lpcv, 2)
  peri = stkget(nf, 3)
  xaxis = stkget(lpcv, 3)
  yaxis = stkget(lpcv, 3)
!
!  call the main driver for computing (and plotting) the integrated
!  periodogram.
!
  call ipgdv (per, nf, n, rstak(peri), freq, rstak(xaxis), &
     rstak(yaxis), istak(isym), lpcv, nprt)

  call stkclr(nall0)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call ipgmp (per, freq, nf, n, ldstak)')
end
subroutine ipgmps ( per, freq, nf, n, ldstak, peri, nprt )

!*****************************************************************************80
!
!! IPGMPS: user routine for the integrated periodogram of a series (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real freq(nf)
!        the array in which the frequencies corresponding to the
!        integrated spectrum values are stored.
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     character*1 llds(8), ln(8), lnf(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer n
!        the actual number of observations in the series from which
!        the periodogram was computed.
!     integer nall0
!        the number of outstanding allocations of the stack at the
!        time of this call.
!     integer nf
!        the number of frequencies at which the periodgram is
!        computed.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        the variable controling printed output, where
!        if nprt ==  0, the output is suppressed,
!        if nprt  >=   1, the output consists of a page plot.
!     real per(nf)
!        the integrated periodogram.
!     real peri(nf)
!        the vector in which the integrated periodogram is stored.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer xaxis
!        the starting location in the stack for
!        the array in which the x axis values to be plotted are stored.
!     integer yaxis
!        the starting location in the stack for
!        the array in which the y axis values to be plotted are stored.
!
  implicit none

  integer &
     ldstak,n,nf,nprt
!
!  array arguments
  real &
     freq(*),per(*),peri(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer isym,ldsmin,lpcv,nall0,xaxis,yaxis
  logical &
     err01,err02,err03,head
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  character &
     llds(8)*1,ln(8)*1,lnf(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external eisge,ipgdv,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  call eisge(nmsub, lnf, nf, (n+2)/2, 1, head, err02, lnf)

  if (err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  if (nprt == 0) then
    ldsmin = 0
  else
    call ldscmp(3, 0, nf+103, 0, 0, 0, 's', 2*nf+206, ldsmin)
  end if

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds)

  if (err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set the size of the work area
!
  call stkset(ldstak, 4)
!
!  set the number of outstanding allocations.
!
  nall0 = stkst(1)

  lpcv = nf + 103
!
!  subdivide the stack.
!
  if (nprt == 0) then
     isym = 1
     xaxis = 1
     yaxis = 1
  else
     isym = stkget(lpcv, 2)
     xaxis = stkget(lpcv, 3)
     yaxis = stkget(lpcv, 3)
  end if
!
!  call the main driver for computing (and plotting) the integrated
!  periodogram.
!
  call ipgdv (per, nf, n, peri, freq, rstak(xaxis), &
     rstak(yaxis), istak(isym), lpcv, nprt)

  call stkclr(nall0)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call ipgmps (per, freq, nf, n, ldstak, peri, nprt)')
end
subroutine ipgms ( yfft, n, lyfft, ldstak, nf, peri, lperi, freq, &
  lfreq, nprt )

!*****************************************************************************80
!
!! IPGMS: user routine for the integrated periodogram of a series (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03, err04, err05
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real freq(lfreq)
!        the array in which the frequencies corresponding to the
!        integrated spectrum values are stored.
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer iextnd
!        the indicator variable used to designate whether zero
!        (iextnd == 0) or the series mean (iextnd  /=  0) is to be
!        used to extend the series.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lfreq
!        the length of the vector freq.
!     character*1 llds(8), llfreq(8), llperi(8), llyfft(8), ln(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lperi
!        the length of the vector peri.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations.
!     integer nall0
!        the number of outstanding allocations of the stack at the
!        time of this call.
!     integer nf
!        the number of frequencies at which the periodgram is
!        to be computed.
!     integer nfft
!        the effective length of the series to be transformed.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        the variable controling printed output, where
!        if nprt ==  0, the output is suppressed,
!        if nprt  >=   1, the output consists of a page plot.
!     real peri(lperi)
!        the vector in which the integrated periodogram is stored.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer xaxis
!        the starting location in the stack for
!        the array in which the x axis values to be plotted are stored.
!     integer yaxis
!        the starting location in the stack for
!        the array in which the y axis values to be plotted are stored.
!     real yfft(lyfft)
!        the array containing the observed time series.
!
  implicit none

  integer &
     ldstak,lfreq,lperi,lyfft,n,nf,nprt
!
!  array arguments
  real &
     freq(*),peri(*),yfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     iextnd,isym,ldsmin,lpcv,nall0,nfft,xaxis,yaxis
  logical &
     err01,err02,err03,err04,err05,head
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external cntr,eisge,ipgdv,ldscmp,pgmmn,setesl,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  if (err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set length of extended series
!
  call setesl(n, 2, nfft)
  nf = nfft/2

  call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err02, llyfft)

  call eisge(nmsub, llperi, lperi, nf, 9, head, err03, llperi)

  call eisge(nmsub, llfreq, lfreq, nf, 9, head, err04, llfreq)

  if (nprt == 0) then
    ldsmin = 0
  else
    call ldscmp(3, 0, nf+103, 0, 0, 0, 's', 2*nfft+206, ldsmin)
  end if

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err05, llds)

  if (err02 .or. err03 .or. err04 .or. err05) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set the size of the work area
!
  call stkset(ldstak, 4)
!
!  set the number of outstanding allocations.
!
  nall0 = stkst(1)

  lpcv = nf + 103
!
!  center the series
!
  call cntr(yfft, n, yfft)
  iextnd = 0
!
!  subdivide the stack.
!
  if (nprt == 0) then
     isym = 1
     xaxis = 1
     yaxis = 1
  else
     isym = stkget(lpcv, 2)
     xaxis = stkget(lpcv, 3)
     yaxis = stkget(lpcv, 3)
  end if
!
!  compute the raw periodogram.
!
  call pgmmn (yfft, n, nfft, iextnd, nf, peri, lperi, rstak(yaxis), &
     freq, lfreq, 0, nmsub)
!
!  call the main driver for computing (and plotting) the integrated
!  periodogram.
!
  call ipgdv (peri, nf, n, peri, freq, rstak(xaxis), &
     rstak(yaxis), istak(isym), lpcv, nprt)

  call stkclr(nall0)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call ipgms (yfft, n, lyfft, ldstak,'/ &
    '      +            nf, peri, lperi, freq, lfreq, nprt)')
end
subroutine ipgord ( peri, nf, n, freq, xaxis, yaxis, isym, npts, lpcv )

!*****************************************************************************80
!
!! IPGORD produces coordinates for the spectral plots.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real ci, cimid
!        the width and midpoint of the test interval for white noise.
!     real freq(nf)
!        the array in which the frequencies at which the periodogram
!        was estimated are stored.
!     integer i
!        an index variable
!     integer ii
!        an index variable
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer n
!        the actual number of observations in the series from which
!        the periodogram was computed.
!     integer nf
!        the number of frequencies for which the spectral estimates
!        are estimated.
!     integer nlim
!        the number of points at which the white noise limits are to
!        plotted.
!     integer npts
!        the number of x, y coordinates to be plotted.
!     real peri(nf)
!        the array containing the integrated periodogram values.
!     real s(40)
!        values used to compute the confidence limits.
!     real xaxis(lpcv), yaxis(lpcv)
!        the x, y coordinates for the spectral plots.
!
  implicit none

  integer &
     lpcv,n,nf,npts
!
!  array arguments
  real &
     freq(nf),peri(nf),xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)

  real &
     ci,cimid
  integer &
     i,ii,nlim
!
!  local arrays
  real &
     s(40)

  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/

  i = n + mod(n,2) - 1

  if (i <= 40) then
     ci = s(i)
  else
     ci = 1.36e0 / sqrt(real(i))
  end if

  xaxis(1:nf) = freq(1:nf)
  yaxis(1:nf) = peri(1:nf)
  isym(1:nf) = 1

  nlim = 101

  ii = nf

  do i = 1, nlim, 2

     cimid = real(i-1) / real(nlim-1)

     if ( 0.0 <= cimid - ci ) then
       ii = ii + 1
       xaxis(ii) = cimid / 2.0e0
       yaxis(ii) = cimid - ci
       isym(ii) = 2
     end if

     if ( cimid + ci <= 1.0e0 ) then
       ii = ii + 1
       xaxis(ii) = cimid / 2.0e0
       yaxis(ii) = cimid + ci
       isym(ii) = 2
     end if

  end do

  npts = ii

  return
end
subroutine ipgout ( xaxis, yaxis, isym, npts, lpcv, ispcer )

!*****************************************************************************80
!
!! IPGOUT produces the integrated periodogram plots.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ispcer
!        an error indicator for the integrated periodogram computations.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer npts
!        the number of x, y coordinates to be plotted.
!     real xaxis(lpcv), yaxis(lpcv)
!        the x, y coordinates for the spectral plots.
!
  implicit none

  integer &
     ispcer,lpcv,npts
!
!  array arguments
  real &
     xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)

  call versp(.true.)
  write ( *, 1000)

  if ( ispcer /= 0 ) then
    write ( *, 1003)
    return
  end if

  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 ( *, 1002)

  return

 1000 format(' integrated sample periodogram (+)'/ &
     5x, ' with 95 per cent test limits for white noise (.)')
!1001 format('+freq'/
!    1   ' period', 9x, 'inf', 7x, '10.', 4x, '5.', 8x, '3.3333', 4x,
!    2   '2.5', 4x, '2.')
 1002 format('+freq'/ &
     ' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, '6.6667', 4x, &
     '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, '2.5', 7x, &
     '2.2222', 4x, '2.')
 1003 format (///' the integrated periodogram of this series', &
     ' could not be computed'/ &
     ' because the variance of the series is zero.')
end
subroutine iprint ( iprt )

!*****************************************************************************80
!
!! IPRINT sets the logical unit for printed output.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iprt
!        the unit number for output.
!
  implicit none

  integer &
     iprt
!
!  external functions
  integer &
     i1mach
  external i1mach

  iprt = i1mach(2)

  return
end
function isamax ( n, x, incx )

!*****************************************************************************80
!
!! ISAMAX indexes the real array element of maximum absolute value.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539:
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector to be examined.
!
!    Input, integer INCX, the increment between successive entries of SX.
!
!    Output, integer ISAMAX, the index of the element of SX of maximum
!    absolute value.
!
  implicit none

  integer i
  integer incx
  integer isamax
  integer ix
  integer n
  real samax
  real x(*)

  if ( n <= 0 ) then

    isamax = 0

  else if ( n == 1 ) then

    isamax = 1

  else if ( incx == 1 ) then

    isamax = 1
    samax = abs ( x(1) )

    do i = 2, n

      if ( samax < abs ( x(i) ) ) then
        isamax = i
        samax = abs ( x(i) )
      end if

    end do

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    isamax = 1
    samax = abs ( x(ix) )

    ix = ix + incx

    do i = 2, n
      if ( samax < abs ( x(ix) ) ) then
        isamax = i
        samax = abs ( x(ix) )
      end if
      ix = ix + incx
    end do

  end if

  return
end
subroutine itsmry ( d, iv, p, v, x )

!***********************************************************************
!
!! ITSMRY prints an iteration summary.
!
!  Modified:
!
!    06 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, real D(P), the scale vector.
!
!    Input/output, integer IV(*), the NL2SOL integer parameter array.
!
!    Input, integer P, the number of variables.
!
!    Input, real V(*), the NL2SOL real array.
!
!    Input, real X(P), the current estimate of the minimizer.
!
  implicit none

  integer p

  integer cov1
  integer :: covmat = 26
  integer :: covprt = 14
  integer :: covreq = 15
  real d(p)
  integer :: dstnrm = 2
  integer :: f = 10
  integer :: f0 = 13
  integer :: fdif = 11
  integer :: g = 28
  integer g1
  integer i
  integer i1
  integer ii
  integer iv(*)
  integer iv1
  integer m
  character ( len = 7 ) model(6)
  integer :: needhd = 39
  integer nf
  integer :: nfcall = 6
  integer :: nfcov = 40
  integer ng
  integer :: ngcall = 30
  integer :: ngcov = 41
  integer :: niter = 31
  integer :: nreduc = 6
  real nreldf
  integer ol
  real oldf
  integer :: outlev = 19
  integer :: preduc = 7
  real preldf
  integer :: prntit = 48
  integer :: prunit = 21
  integer pu
  real reldf
  integer :: reldx = 17
  integer :: size = 47
  integer :: solprt = 22
  integer :: statpr = 23
  integer :: stppar = 5
  integer :: sused = 57
  real v(*)
  real x(p)
  integer :: x0prt = 24

  data model / &
    '      G', &
    '      S', &
    '    G-S', &
    '    S-G', &
    '  G-S-G', &
    '  S-G-S' /

  pu = iv(prunit)

  if ( pu == 0 ) then
    return
  end if

  iv1 = iv(1)
  ol = iv(outlev)

  if ( iv1 < 2 .or. 15 < iv1 ) then
    write ( pu, '(a,i5)' ) 'IV(1) = ', iv1
    return
  end if

  if ( ol == 0 ) then
    go to 20
  end if

  if ( 12 <= iv1 ) then
    go to 20
  end if

  if ( 10 <= iv1 .and. iv(prntit) == 0 ) then
    go to 20
  end if

  if ( iv1 <= 2 ) then
    iv(prntit) = iv(prntit) + 1
    if ( iv(prntit) < abs ( ol ) ) then
      return
    end if
  end if

!10   continue

      nf = iv(nfcall) - abs ( iv(nfcov) )
      iv(prntit) = 0
      reldf = 0.0E+00
      preldf = 0.0E+00
      oldf = v(f0)

      if ( 0.0E+00 < oldf ) then
         reldf = v(fdif) / oldf
         preldf = v(preduc) / oldf
      end if
!
!  Print short summary line.
!
      if ( ol <= 0 ) then

         if ( iv(needhd) == 1 ) then
           write ( pu, * ) ' '
           write ( pu, '(a)' ) &
           '    it    nf      f        reldf      preldf     reldx'
         end if

         iv(needhd) = 0
         write(pu,1017) iv(niter), nf, v(f), reldf, preldf, v(reldx)
!
!  Print long summary line.
!
      else

        if ( iv(needhd) == 1 ) then
          write ( pu, * ) ' '
          write ( pu, * ) &
            '    it    nf      f        reldf      preldf     reldx' // &
            '    model    STPPAR      size      d*step     npreldf'
        end if

      iv(needhd) = 0
      m = iv(sused)
      if ( 0.0E+00 < oldf ) then
        nreldf = v(nreduc) / oldf
      else
        nreldf = 0.0E+00
      end if

      write(pu,1017) iv(niter), nf, v(f), reldf, preldf, v(reldx), &
                     model(m), v(stppar), v(size), &
                     v(dstnrm), nreldf
 1017 format(1x,i5,i6,4e11.3,a7,4e11.3)

  end if

 20   continue

  if ( iv1 == 1 ) then

    return

  else if ( iv1 == 2 ) then

    return

  else if ( iv1 == 3 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'X-convergence.'

  else if ( iv1 == 4 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'Relative function convergence.'

  else if ( iv1 == 5 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'X- and relative function convergence.'

  else if ( iv1 == 6 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'Absolute function convergence.'

  else if ( iv1 == 7 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'Singular convergence.'

  else if ( iv1 == 8 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'False convergence.'

  else if ( iv1 == 9 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'Function evaluation limit.'

  else if ( iv1 == 10 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'Iteration limit.'

  else if ( iv1 == 11 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'Stopx.'

  else if ( iv1 == 14 ) then

    write ( pu, * ) ' '
    write ( pu, '(a)' ) 'Bad parameters to ASSESS.'
    return
!
!  Initial call on ITSMRY.
!
  else if ( iv1 == 12 .or. iv1 == 13 .or. iv1 == 15 ) then

    if ( iv1 == 15 ) then
      write ( pu, * ) ' '
      write ( pu, '(a)' ) 'J could not be computed.'
      if ( 0 < iv(niter) ) then
        go to 190
      end if
    end if

    if ( iv1 == 13 ) then
      write ( pu, * ) ' '
      write ( pu, '(a)' ) 'Initial sum of squares overflows.'
    end if

    if ( iv(x0prt) /= 0 ) then
      write ( pu, * ) ' '
      write ( pu, * ) '     I     Initial X(i)      D(i)'
      write ( pu, * ) ' '
      write(pu,1150) (i, x(i), d(i), i = 1, p)
    end if

 1150 format((1x,i5,e17.6,e14.3))

    if ( iv1 == 13 ) then
      return
    end if

    iv(needhd) = 0
    iv(prntit) = 0

    if ( ol == 0 ) then
      return
    else if ( ol < 0 ) then
      write ( pu, '(a)' ) ' '
      write ( pu, '(a)' ) &
        '    it    nf      f        reldf      preldf     reldx'
    else if ( 0 < ol ) then
      write ( pu, '(a)' ) ' '
      write ( pu, '(a)' ) &
        '    it    nf      f        reldf      preldf     reldx' // &
        '    model    STPPAR      size      d*step     npreldf'
    end if

    write ( pu, * ) ' '
    write(pu,1160) v(f)
 1160 format('     0     1',e11.3,11x,e11.3)
    return

  else

    return

  end if
!
!  Print various information requested on solution.
!
      iv(needhd) = 1

      if ( iv(statpr) /= 0 ) then

         oldf = v(f0)

         if ( 0.0E+00 < oldf ) then
           preldf = v(preduc) / oldf
           nreldf = v(nreduc) / oldf
         else
           preldf = 0.0E+00
           nreldf = 0.0E+00
         end if

         nf = iv(nfcall) - iv(nfcov)
         ng = iv(ngcall) - iv(ngcov)
         write ( pu, * ) ' '
         write(pu,1180) v(f), v(reldx), nf, ng, preldf, nreldf
 1180 format(' function',e17.6,'   reldx',e20.6/' func. evals', &
         i8,9x,'grad. evals',i8/' preldf',e19.6,3x,'npreldf',e18.6)

         if ( 0 < iv(nfcov) ) then
           write ( pu, * ) ' '
           write ( pu, '(i5,a)' ) iv(nfcov), &
             ' extra function evaluations for covariance.'
         end if

         if ( 0 < iv(ngcov) ) then
           write ( pu, '(i5,a)' ) iv(ngcov), &
             ' extra gradient evaluations for covariance.'
         end if
      end if

 190  continue

      if ( iv(solprt) /= 0 ) then

         iv(needhd) = 1
         g1 = iv(g)

         write ( pu, '(a)' ) ' '
         write ( pu, '(a)' ) &
           '     I      Final X(I)        D(I)          G(I)'
         write ( pu, '(a)' ) ' '

         do i = 1, p
           write ( pu, '(i5,e17.6,2e14.3)' ) i, x(i), d(i), v(g1)
           g1 = g1 + 1
         end do

      end if

      if ( iv(covprt) == 0 ) then
        return
      end if

      cov1 = iv(covmat)
      iv(needhd) = 1

      if ( cov1 < 0 ) then

        if ( -1 == cov1 ) then
          write ( pu, '(a)' ) 'Indefinite covariance matrix'
        else if ( -2 == cov1 ) then
          write ( pu, '(a)' ) 'Oversize steps in computing covariance'
        end if

      else if ( cov1 == 0 ) then

        write ( pu, '(a)' ) 'Covariance matrix not computed'

      else if ( 0 < cov1 ) then

        write ( pu, * ) ' '
        i = abs ( iv(covreq) )
        if ( i <= 1 ) then
          write ( pu, '(a)' ) 'Covariance = scale * H**-1 * (J'' * J) * H**-1'
        else if ( i == 2 ) then
          write ( pu, '(a)' ) 'Covariance = scale * inverse ( H )'
        else if ( 3 <= i ) then
          write ( pu, '(a)' ) 'Covariance = scale * inverse ( J'' * J )'
        end if
        write ( pu, * ) ' '

        ii = cov1 - 1
        if ( ol <= 0 ) then
          do i = 1, p
            i1 = ii + 1
            ii = ii + i
            write(pu,1270) i, v(i1:ii)
          end do
 1270 format(' row',i3,2x,5e12.4/(9x,5e12.4))
        else

          do i = 1, p
            i1 = ii + 1
            ii = ii + i
            write(pu,1250) i, v(i1:ii)
          end do

 1250 format(' row',i3,2x,9e12.4/(9x,9e12.4))

    end if

  end if

  return
end
function j4save ( which, value, set )

!*****************************************************************************80
!
!! J4SAVE saves variables needed by the library error handling routines.
!
!  Discussion:
!
!    The internal parameters are initialized to the following values:
!
!    #1 =  0, NERR, the index of the most recent error;
!    #2 =  0, KONTRL, error control flag (0 means only level 2 errors are fatal,
!             and get a printout, while lower level errors get no printout.)
!    #3 =  0, IUNIT, the main error output unit (0 means use standard output).
!    #4 = 10, MAXMES, the maximum number of times any message is printed.
!    #5 =  1, NUNIT, total number of error output units in use.
!    #6 = -1, second error output unit (-1 means not being used).
!    #7 = -1, third error output unit (-1 means not being used).
!    #8 = -1, fourth error output unit (-1 means not being used).
!    #9 = -1, fifth error output unit (-1 means not being used).
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, integer WHICH, the index of the item desired.
!    1, NERR, the current error number.
!    2, KONTRL, the current error control flag.
!    3, IUNIT, the current unit number to which error messages are sent.  
!       (0 means use standard.)
!    4, MAXMES, the maximum times any message is printed (as set by xermax).
!    5, NUNIT, the number of units to which each error message is written.
!    6, the 2nd unit for error messages.
!    7, the 3rd unit for error messages.
!    8, the 4th unit for error messages.
!    9, the 5th unit for error messages.
!
!    Input, integer VALUE, the value to be set for the WHICH-th parameter,
!    if SET is TRUE.
!
!    Input, logical SET.
!    TRUE: the WHICH-th parameter will be given the value, VALUE.  
!
!    Output, integer J4SAVE, the old value of the WHICH-th parameter.
!
  implicit none

  integer j4save
  integer, save, dimension ( 9 ) :: param = (/  &
    0, 2, 0, 10, 1, -1, -1, -1, -1 /)
  logical set
  integer value
  integer which

  if ( which < 1 .or. 9 < which ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'J4SAVE - Fatal error!'
    write ( *, '(a,i10)' ) '  Illegal input value of WHICH = ', which
    stop
  end if

  j4save = param(which)

  if ( set ) then
    param(which) = value
  end if

  return
end
subroutine ldscmp ( narr, nlog, nint, nreal, ndbl, ncmp, &
     flag, nfp, ldsmin )

!*****************************************************************************80
!
!! LDSCMP computes storage needed for arrays.
!
!  Discussion:
!
!    Computes ldsmin, the minimum number of double precision locations
!    needed by the framework to store narr arrays, comprising nlog
!    logical locations, nint integer locations, nreal real locations,
!    ndbl double precision locations, and ncmp complex locations,
!    together with the nover overhead integer locations that the
!    framework always uses and the 3 overhead locations that it uses
!    per array stored.  (all the locations are assigned out of the
!    labeled common cstak, using a stack discipline.)
!
!    it is assumed, based upon the fortran standard (ansi x3.9 1966),
!    that double precision and complex data elements are twice as long
!    as integer and logical elements.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     character*1 flag
!        the indicator variable used to designate whether the nfp
!        elements are real or double precision, where flag=s indicates
!        the nfp elements are real (single precision), and flag=d
!        indicates the elements are double precision.
!     integer ldsmin
!        output parameter.  the minimum number of double precision
!        locations in cstak required for the quantities of array
!        elements and arrays specified by the input parameters.
!     integer narr
!        input parameter.  the number of arrays to be stored in cstak.
!     integer ncmp
!        input parameter.  the number of complex elements in the
!        arrays to be stored in cstak.
!     integer ndbl
!        input parameter.  the number of double precision elements in
!        the arrays to be stored, in cstak.
!     integer nfp
!        the number of elements which depend on the precision of the
!        version of starpac being used.
!     integer nint
!        input parameter.  the number of integer elements in the
!        arrays to be stored in cstak.
!     integer nlog
!        input parameter.  the number of logical elements in the
!        arrays to be stored in cstak.
!     integer nover
!        the number of integer locations that the framework always
!        uses for overhead purposes.
!     integer nreal
!        input parameter.  the number of real elements in the arrays
!        to be stored in cstak.
!
  implicit none

  integer &
     ldsmin,narr,ncmp,ndbl,nfp,nint,nlog,nreal
  character &
     flag*1

  integer &
     nover

  data nover /10/

  ldsmin = (nlog + nint + nreal + 3*narr + nover + 1)/2 &
         + ndbl + ncmp
  if (flag == 's') then
     ldsmin = ldsmin + (nfp+1)/2
  else
     ldsmin = ldsmin + nfp
  end if

  return
end
subroutine linvrt ( n, lin, l )

!***********************************************************************
!
!! LINVRT computes the inverse of a lower triangular matrix.
!
!  Discussion:
!
!    LIN = inverse ( L ), both N by N lower triangular matrices stored
!    compactly by rows.  LIN and L may share the same storage.
!
!  Modified:
!
!    05 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer N, the order of L and LIN.
!
!    Output, real LIN((N*(N+1))/2), the inverse of L, a lower triangular
!    matrix stored by rows.
!
!    Input, real L((N*(N+1))/2), a lower triangular matrix stored by rows.
!
  implicit none

  integer n

  integer i
  integer ii
  integer j0
  integer j1
  integer jj
  integer k
  integer k0
  real l((n*(n+1))/2)
  real lin((n*(n+1))/2)
  real t

  j0 = ( n * ( n + 1 ) ) / 2

  do ii = 1, n

    i = n + 1 - ii
    lin(j0) = 1.0E+00 / l(j0)

    if ( i <= 1 ) then
      return
    end if

    j1 = j0

    do jj = 1, i - 1

      t = 0.0E+00
      j0 = j1
      k0 = j1 - jj

      do k = 1, jj
        t = t - l(k0) * lin(j0)
        j0 = j0 - 1
        k0 = k0 + k - i
      end do

      lin(j0) = t / l(k0)

    end do

    j0 = j0 - 1

  end do

  return
end
subroutine litvmu ( n, x, l, y )

!***********************************************************************
!
!! LITVMU solves L' * X = Y, where L is a lower triangular matrix.
!
!  Discussion:
!
!    This routine solves L' * X = Y, where L is an N by N lower
!    triangular matrix stored compactly by rows.  X and Y may occupy
!    the same storage.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer N, the order of L.
!
!    Output, real X(N), the solution.
!
!    Input, real L((N*(N+1))/2), the lower triangular matrix, stored
!    by rows.
!
!    Input, real Y(N), the right hand side.
!
  implicit none

  integer n

  integer i
  integer i0
  integer ii
  integer ij
  integer j
  real l((n*(n+1))/2)
  real x(n)
  real xi
  real y(n)

  x(1:n) = y(1:n)
  i0 = ( n * ( n + 1 ) ) / 2

  do ii = 1, n

    i = n + 1 - ii
    xi = x(i) / l(i0)
    x(i) = xi

    if ( i <= 1 ) then
      return
    end if

    i0 = i0 - i

    if ( xi /= 0.0E+00 ) then

      do j = 1, i - 1
        ij = i0 + j
        x(j) = x(j) - xi * l(ij)
      end do

    end if

  end do

  return
end
subroutine livmul ( n, x, l, y )

!***********************************************************************
!
!! LIVMUL solves L * X = Y, where L is a lower triangular matrix.
!
!  Discussion:
!
!    This routine solves L * X = Y, where L is an N by N lower
!    triangular matrix stored compactly by rows.  X and Y may occupy
!    the same storage.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer N, the order of L.
!
!    Output, real X(N), the solution.
!
!    Input, real L((N*(N+1))/2), the lower triangular matrix, stored
!    by rows.
!
!    Input, real Y(N), the right hand side.
!
  implicit none

  integer n

  real dotprd
  integer i
  integer j
  real l((n*(n+1))/2)
  real t
  real x(n)
  real y(n)

  x(1) = y(1) / l(1)

  j = 1

  do i = 2, n
    t = dotprd ( i-1, l(j+1), x )
    j = j + i
    x(i) = ( y(i) - t ) / l(j)
  end do

  return
end
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 )

!*****************************************************************************80
!
!! LLCNT is the controlling subroutine for linear least squares.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer acc
!        the starting location in the work area for
!        the number of accurate digits.
!     integer c
!        *
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer fc
!        the starting location in the work area for
!        the orthonormalization matrix.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ifit
!        the indicator value designating whether the fit is of a
!        general model (ifit=3) or a polynomial model (ifit=1).
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        single precision and ifp=4 indicates double precision.
!     integer iptout(4)
!        the variable used to control printed output for each section.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ixm
!        the first dimension of the matrix xm.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     external llhdr
!        the name of the routine that produced the heading.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer nall0
!        number of allocations on entry.
!     integer ndigit
!        the number of digits in the print control value.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(lpar)
!        the parameters to be estimated.
!     integer pari
!        the starting location in the work area of
!        the parameters to be estimated.
!     integer par1
!        the starting location in the work area for
!        the parameters to be estimated ommitting the last
!        independent variable.
!     real pv(lpv)
!        the predicted values.
!     integer pvi
!        the starting location in the work area for
!        the predicted values.
!     integer red
!        the starting location in the work area for
!        the reduction to the sum of squares due to each parameter.
!     real res(n)
!        the residuals.
!     integer resi
!        the starting location in the work area for
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     integer rsdi
!        the starting location in the work area for
!        the residual standard deviation.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     integer sdpvi
!        the starting location in the work area for
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     integer sdresi
!        the starting location in the work area for
!        the standardized residuals.
!     integer t
!        the starting location in the work area for
!        the triangular matrix from the decomposition.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     integer vcvi
!        the starting location in the work area for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the weights.
!     integer wti
!        the starting location in the work area for
!        the weights.
!     integer wy
!        the starting location in the work area for
!        the vector containing sqrt(wt)*y.
!     real xm(ixm,m)
!        the independent variable.
!     integer xmw
!        the starting location in the work area for
!        the matrix containing xm * sqrt(wt).
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     rsd
  integer &
     ifit,ivcv,ixm,ldstak,lpar,lpv,lsdpv,lsdres,lwt,m,n,npar, &
     nprt
  logical &
     save,weight
!
!  array arguments
  real &
     par(*),pv(lpv),res(*),sdpv(lsdpv),sdres(lsdres),vcv(*),wt(lwt),xm(*),y(*)
  character &
     nmsub(6)*1
!
!  subroutine arguments
  external llhdr
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     acc,c,fc,ifp,nall0,ndigit,nnzw,par1,pari,pvi,red,resi, &
     rsdi,sdpvi,sdresi,t,vcvi,wti,wy,xmw
  logical &
     page,wide
!
!  local arrays
  real &
     rstak(12)
  integer &
     iptout(4),istak(12)
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external cpymss,ller,llsmn,prtcnt,scopy,setrv,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))

  wide = .true.
  page = .false.
  ndigit = 4

  ifp = 3
!
!  set print control values
!
  call prtcnt(nprt, ndigit, iptout)
!
!  check for errors
!
  call ller(nmsub, ixm, ivcv, n, npar, lpar, ldstak, wt, lwt, &
     weight, nnzw, ifit, save)
  if (ierr /= 0) return

  call stkset(ldstak, 4)
  nall0 = stkst(1)
!
!  set up subdivision of work areas
!
  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)

  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)
!
!  equivalenced locations within scrat
!
  fc = xmw
!
!  Set up weight vector.
!
  if (weight) then
     call scopy(n, wt, 1, rstak(wti), 1)
  else
     call setrv(rstak(wti), n, 1.0e0)
  end if

  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)

  call scopy(n, rstak(resi), 1, res, 1)

  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)

  if (ierr == 3) ierr = 2
  if (ierr == 4) ierr = 3

  return
end
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 )

!*****************************************************************************80
!
!! LLCNTG is the controlling subroutine for general linear least squares.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ifit
!        the indicator value designating whether the lls is of a
!        general model (ifit=3) or a polynomial model (ifit=1).
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ixm
!        the first dimension of the matrix xm.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     external llhdrg
!        the name of the routine that produced the heading.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(lpar)
!        the parameters to be estimated.
!     real pv(lpv)
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lwt)
!        the weights (a dummy vector in the unweighted case).
!     real xm(ixm,m)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     rsd
  integer &
     ivcv,ixm,ldstak,lpar,lpv,lsdpv,lsdres,lwt,n,npar,nprt
  logical &
     save,weight
!
!  array arguments
  real &
     par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     ifit,m
!
!  external subroutines
  external llcnt,llhdrg
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr

  ifit = 3
  m = npar

  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)

  return
end
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 )

!*****************************************************************************80
!
!! LLCNTP is the controlling subroutine for polynomial linear least squares.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ifit
!        the indicator value designating whether the lls is of a
!        general model (ifit=3) or a polynomial model (ifit=1).
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ixm
!        the first dimension of the matrix xm.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     external llhdrp
!        the name of the routine that produced the heading.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer ndeg
!        the degree of the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(lpar)
!        the parameters to be estimated.
!     real pv(lpv)
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lwt)
!        the weights (a dummy vector in the unweighted case).
!     real xm(n,1)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     rsd
  integer &
     ivcv,ldstak,lpar,lpv,lsdpv,lsdres,lwt,n,ndeg,npar,nprt
  logical &
     save,weight
!
!  array arguments
  real &
     par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     ifit,ixm,m
!
!  external subroutines
  external llcnt,llhdrp
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr

  ifit = 1
  npar = ndeg + 1
  m = 1
  ixm = n

  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)

  return
end
subroutine ller ( nmsub, ixm, ivcv, n, npar, lpar, ldstak, wt, lnwt, &
     weight, nnzw, ifit, save )

!*****************************************************************************80
!
!! LLER is the error checking routine for the linear least squares routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     logical error(10)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifit
!        the indicator value designating whether the lls is of a
!        general model (ifit=3) or a polynomial model (ifit=1).
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldstak
!        the length of the array dstak.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     character*1 livcv(8), lixm(8), llpar(8), llds(8), ln(8), lnc(8),
!    *   lndeg(8), lndeg1(8), lnpar(8), ln1(8), lone(8), lwt(8),
!    *   lzero(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer lpar
!        the actual length of the vector p.
!     integer lnwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer nzw
!        the number of zero weights.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lnwt)
!        the user supplied weights.
!
  implicit none

  integer &
     ifit,ivcv,ixm,ldstak,lnwt,lpar,n,nnzw,npar
  logical &
     save,weight
!
!  array arguments
  real &
     wt(lnwt)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,ldsmin,nzw
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,eisii,ervwt,ldscmp
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  error(1:10) = .false.

  if ( ifit /= 1 ) then
    lnc(1:8) = lnpar(1:8)
  else
    lnc(1:8) = lndeg1(1:8)
  end if

  call eisge(nmsub, ln, n, 1, 1, head, error(1), ln)

  if (ifit == 3) then
     call eisii(nmsub, lnpar, npar, 1, n, 1, head, error(2), lone, &
     ln)
  end if

  if (ifit == 1) &
     call eisii(nmsub, lndeg, npar-1, 0, n-1, 1, head, error(2), &
        lzero, ln1)

  call eisge(nmsub, lixm, ixm, n, 3, head, error(4), ln)

  if (save .and. (ifit == 1)) &
     call eisge(nmsub, llpar, lpar, npar, 7, head, error(5), lndeg1)

  if (save) &
      call eisge(nmsub, livcv, ivcv, npar, 3, head, error(6), lnc)

  if (error(1) .or. error(2) .or. error(3)) then
    ierr = 1
    return
  end if

  nnzw = n
  if (weight) call ervwt(nmsub, lwt, wt, n, npar, head, nnzw, &
     nzw, 2, error(8), lnc)

  call ldscmp(15, 0, 0, 0, 0, 0, 's', &
              6*n + npar*(n+2*npar+5) + 1, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(9), llds)

  do i=1,10
    if ( error(i) ) then
      ierr = 1
      return
    end if
  end do

  return
end
subroutine llhdrg ( page, wide, isubhd )

!*****************************************************************************80
!
!! LLHDRG: page headings for the unrestricted linear least squares routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide
!
!  external subroutines
  external versp

  if (page) write ( *,1020)
  call versp(wide)
  if (page) write ( *,1000)
  if (.not.page) write ( *,1010)
  page = .true.

  if (isubhd == 0) return

  write ( *,1030)

  return

 1000 format ('+linear least squares estimation', &
    ' with user-specified model, continued')
 1010 format ('+', 63('*')/ &
     1x, '*  linear least squares estimation', &
     ' with user-specified model  *'/ 1x, 63('*'))
 1020 format ('1')
 1030 format (//' summary of initial conditions'/ 1x, 30('-'))
end
subroutine llhdrp ( page, wide, isubhd )

!*****************************************************************************80
!
!! LLHDRP: page headings for polynomial linear least squares routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide

!
!  external subroutines
  external versp

  if (page) write ( *,1020)
  call versp(wide)
  if (page) write ( *,1000)
  if (.not.page) write ( *,1010)
  page = .true.

  if (isubhd == 0) return

  write ( *,1030)

  return

 1000 format ('+linear least squares estimation', &
     ' with polynomial model, continued')
 1010 format ('+', 59('*')/ &
     1x, '*  linear least squares estimation', &
     ' with polynomial model  *'/ 1x, &
     59('*'))
 1020 format ('1')
 1030 format (//' summary of initial conditions'/ 1x, 30('-'))
end
subroutine lls ( y, xm, n, ixm, npar, res, ldstak )

!*****************************************************************************80
!
!! LLS is the general linear model least squares fit routine.
!
!  Discussion:
!
!    call for general linear model least squares fit
!    no weights specified
!    no storage other than residuals
!    four pages automatic printout
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ixm
!        the first dimension of the matrix xm.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(1)
!        a dummy array for
!        the parameters  to be estimated.
!     real pv(1)
!        a dummy array for
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(1)
!        a dummy array for
!        the standard deviations of the predicted values.
!     real sdres(1)
!        a dummy array for
!        the standardized residuals.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        a dummy array for
!        the weights.
!     real xm(ixm,npar)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     ixm,ldstak,n,npar
!
!  array arguments
  real &
     res(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     rsd
  integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,nprt
  logical &
     save,weight
!
!  local arrays
  real &
     par(1),pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external llcntg
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s',' ',' ',' '/

  weight = .false.
  save = .false.
  nprt = 1111
  lpar = 1
  lpv = 1
  lsdpv = 1
  lsdres = 1
  ivcv = 1
  lwt = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (//' the correct form of the call statement is'// &
     '       call lls (y, xm, n, ixm, npar, res, lsdtak)')
end
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 )

!*****************************************************************************80
!
!! LLSMN: main program for the linear least squares fitting.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real acc(npar)
!        the number of accurate digits.
!     real c(npar)
!        a work vector.
!     real cond
!        the condition number of the design matrix.
!     logical const
!        an indicator value designating whether the first column of
!        the design matrix is all ones for a constant.
!     real det(2)
!        the determinent.
!     real df
!        the degrees of freedom.
!     real fc(n,npar)
!        the orthonormalization matrix.
!     real fplm
!        the floating point largest magnitude.
!     real fplrs
!        the floating point largest relative spacing.
!     real fpspm
!        the floating point smallest positive magnitude.
!     integer i
!        an index.
!     integer idf
!        the degrees of freedom
!     integer idf1
!        the degrees of freedom for the fit without the last independent
!        variable.
!     integer ier
!        the error flag returned by the inversion routines.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ifit
!        the indicator value designating whether the fit is of a
!        general model (ifit=3) or a polynomial model (ifit=1).
!     integer iptout(4)
!        the variable used to control printed output for each section.
!     integer irefit
!        an indicator used to designate whether the fit is of the
!        full design matrix (irefit=0) or is omitting the last
!        independent variable (irefit=1).
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer ix
!        the first dimension of the matrix x.
!     external llhdr
!        the name of the routine that produced the heading.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer nc
!        the number of parameters being fit.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the parameters  to be estimated.
!     real par1(npar)
!        the parameters to be estimated ommitting the last
!        independent variable.
!     real probt
!        ...
!     real probt1
!        ...
!     real pv(n)
!        the predicted values.
!     real px
!        a work variable.
!     real ratio
!        the ratio of the parameters to their standard deviations.
!     real ratio1
!        the ratio of the parameters computed omitting the last
!        independent variable to their standard deviations.
!     real red(npar)
!        the reduction to the sum of squares due to each parameter.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     real rsd1
!        the residual standard deviation from the fit omitting
!        the last independent variable.
!     real rss
!        the residual sum of squares.
!     real rss1
!        the residual sum of squares from the fit omitting
!        the last independent variable.
!     real rvar
!        the residual variance.
!     real rvar1
!        the residual variance from the fit omitting
!        the last independent variable.
!     real r2
!        the multiple correlation parameter.
!     real sdc
!        the estimated standard deviations of the parameters.
!     real sdc1
!        the estimated standard deviations of the parameters omitting
!        the last independent variable.
!     real sdpv(n)
!        the standard deviations of the predicted values.
!     real sdres(n)
!        the standardized residuals.
!     real sm
!        a work variable.
!     real t(npar,npar)
!        the triangular matrix from the decomposition.
!     real td
!        a work variable.
!     real vcv(npar,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(n)
!        the weights (a dummy vector in the unweighted case).
!     real wtsqrt
!        the square root of the weight.
!     real wtsum
!        the sum of the weights.
!     real wtym
!        the sum of the weighted dependent variables.
!     real wy(n)
!        the vector containing sqrt(wt)*y.
!     real x(ix,m)
!        the independent variable.
!     real xw(n,npar)
!        the matrix containing x * sqrt(wt).
!     real y(n)
!        the dependent variable.
!     real ysum
!        the sum of the weighted dependent variables squared.
!
  implicit none

  real &
     rsd
  integer &
     ifit,ix,m,n,nnzw,npar
  logical &
     page,weight,wide
!
!  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)
!
!  subroutine arguments
  external llhdr
!
!  scalars in common
  integer &
     ierr
!
!
  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,irefit,isubhd,j,k,nc
  logical &
     const
!
!  local arrays
  real &
     det(2)
!
!  external functions
  real &
     cdft
  external cdft
!
!  external subroutines
  external accdig,fitpt1,fitpt2,mgs,oanova,vcvout
!
!  common blocks
  common /errchk/ierr

  fplm = huge ( fplm )
  fplrs = epsilon ( fplrs )
  fpspm = tiny ( fpspm )
  nc = npar
  idf = nnzw - nc
  df = real ( idf )

  r2 = 0.0
  rvar1 = 0.0
  rsd1 = 0.0
  j = 0
  idf1 = 0
  const = .false.

  ysum = 0.0e0
  wtsum = 0.0e0
  do i=1,n
    if ( 0.0E+00 < wt(i) ) then
      ysum = ysum + wt(i)*y(i)*y(i)
      wtsum = wtsum + wt(i)
    end if
  end do
!
!  begin fit
!
  irefit = -1
!
!  if irefit is equal to 1 fit is omitting the last variable
!
   50 irefit = irefit + 1
!
!  compute working vectors
!
  wtym = 0.0e0
  i = 0

  do k=1,n

     if (wt(k) <= 0.0e0) then
       cycle
     end if

     wtsqrt = sqrt(wt(k))
     i = i + 1
     px = wtsqrt
     do j=1,nc
        if (ifit == 1 .and. j >= 2) px = px*x(k,1)
        if (ifit == 3) px = x(k,j)*wtsqrt
        xw(i,j) = px
     end do
!
!  compute wy ( weights * y vector )
!
     wy(i) = y(k)*wtsqrt
     wtym = wtym + wt(k)*y(k)

  end do

  wtym = wtym/wtsum
!
!  compute estimated values of parameters
!
  if (irefit == 1) go to 80
  ier = 0
  call mgs(xw, wy, nnzw, nc, par, c, t(1,1), t, npar, n, ier)
  if (ier == 0) go to 90
  ierr = 3
  isubhd = 0
  call llhdr(page, wide, isubhd)
  write ( *,1160)
  write ( *,1150)
  return
   80 continue
  ier = 0
  call mgs(xw, wy, nnzw, nc, par1, c, t(1,1), t, npar, n, ier)
!
!  compute predicted values (pv) and residuals (res)
!  residual sum of squares (rss) and
!  residual standard deviation (rsd) and
!  sum of weights (wtsum) and
!  residual varaince (rvar)
!
   90 rss = 0.0e0
  rss1 = 0.0e0
  do i=1,n

     sm = 0.0e0
     px = 1.0e0
     do j=1,nc
        if (ifit == 1 .and. j >= 2) px = px*x(i,1)
        if (ifit == 3) px = x(i,j)
        if (irefit == 0) sm = sm + par(j)*px
        if (irefit == 1) sm = sm + par1(j)*px
     end do

     if (irefit == 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

  end do

  if (irefit == 0) go to 130
  rvar1 = rss1/(df+1.0e0)
  rsd1 = sqrt(rvar1)
  go to 380
  130 rvar = 0.0e0
  if (df > 0.0e0) rvar = rss/df
  rsd = sqrt(rvar)
!
!  compute multiple correlation parameter squared (r2)
!
  sm = 0.0e0
  const = .true.
  do i=1,n
     if ((x(i,1) /= 1.0e0) .and. (ifit == 3)) const = .false.
     sm = sm + (y(i)-wtym)*wt(i)*(y(i)-wtym)
  end do
  r2 = 1.0e0
  if (sm > 0.0e0) r2 = 1.0e0-rss/sm
!
!  check for -exact- fit
!
  td = 0.0e0
  if (df > 0.0e0) td = sqrt(rss)
  if (ysum > 0.0e0) td = td/sqrt(ysum)
  if (td > 10.0e0*fplrs) go to 180

  ierr = 0
  if ((iptout(1) == 0) .and. (iptout(2) == 0) .and. (iptout(3) == 0) &
     .and. (iptout(4) == 0)) go to 145
  isubhd = 0
  call llhdr(page, wide, isubhd)
  write ( *,1180)
  write ( *,1020) (i,par(i),i=1,npar)
!
!  zero out vcv matrix and sdres and sdpv vectors
!
  145 continue
  sdpv(1:n) = 0.0e0
  sdres(1:n) = 0.0e0
  vcv(1:npar,1:npar) = 0.0e0
  return

  180 continue
!
!  compute orthonormalization
!
  do i=1,nc
    t(i,i) = sqrt(t(i,1))
    do j=i,nc
      if ( i /= j) then
        t(i,j) = t(i,j)*t(i,i)
      end if
    end do
  end do

  call strco ( t, npar, nc, cond, c, 1 )

  if ( cond /= 0.0e0 ) then
     cond = 1.0e0/cond
  else
     cond = fplm
  end if

  call strdi ( t, npar, nc, det, 011, ier )

  if (ier /= 0) then
    ierr = 3
    isubhd = 0
    call llhdr(page, wide, isubhd)
    write ( *,1160)
    write ( *,1120)
    return
  end if

! 210 continue

  do i=1,n
     do j=1,nc
        sm = 0.0e0
        px = 1.0e0
        do k=1,j
           if (ifit == 1 .and. k >= 2) px = px*x(i,1)
           if (ifit == 3) px = x(i,k)
           sm = sm + px*t(k,j)
        end do
        fc(i,j) = sm
     end do
  end do
!
!  compute reduction to rss due to fitting
!
  do j=1,nc
     sm = 0.0e0
     do i=1,n
        sm = sm + (fc(i,j))*wt(i)*y(i)
     end do
     red(j) = (sm*sm)
  end do
!
!  compute estimated variance covariance matrix
!
  do i=1,nc
     do j=i,nc
        sm = 0.0e0
        do k=j,nc
           sm = sm + t(i,k)*t(j,k)
        end do
        if (sqrt(abs(sm))*sqrt(rvar) >= sqrt(fpspm)) then
           vcv(i,j) = sm*rvar
        else
           vcv(i,j) = 0.0e0
        end if
        vcv(j,i) = vcv(i,j)
     end do
  end do
!
!  refit to predicted values
!
  i = 0
  do k=1,n
    if (wt(k) <= 0.0e0) then
      cycle
    end if
    wtsqrt = sqrt(wt(k))
    i = i + 1
    px = wtsqrt
    do j=1,nc
      if (ifit == 1 .and. j >= 2) px = px*x(k,1)
      if (ifit == 3) px = x(k,j)*wtsqrt
      xw(i,j) = px
    end do
    wy(i) = pv(k)*wtsqrt
  end do

  ier = 0
  call mgs(xw, wy, nnzw, nc, par1, c, t(1,1), t, npar, n, ier)

  call accdig(par, par1, acc, nc)
!
!  compute standard deviation of predicted values (sdpv)
!  and standardized residuals (sdres)
!
  do i=1,n
     sm = 0.0e0
     do j=1,nc
        sm = 0.0e0
        px = 1.0e0
        do k=1,nc
           if (ifit == 1 .and. k >= 2) px = px*x(i,1)
           if (ifit == 3) px = x(i,k)
           sm = sm + px*vcv(j,k)
        end do
        xw(i,j) = sm
     end do

     sm = 0.0e0
     px = 1.0e0
     do k=1,nc
        if (ifit == 1 .and. k >= 2) px = px*x(i,1)
        if (ifit == 3) px = x(i,k)
        sm = sm + xw(i,k)*px
     end do

     sm = max(0.0e0, sm)
     sdpv(i) = sqrt(sm)
     sdres(i) = fplm

     if ( 0.0 < wt(i) ) then
       if ((rvar/wt(i)-sm) <= 0.0e0) ierr = 4
       if (rvar/wt(i)-sm > 0.0e0) &
          sdres(i) = (res(i)/sqrt(rvar/wt(i)-sm))
     end if

  end do
!
!  check for printed output
!
  if ((iptout(1) == 0) .and. (iptout(2) == 0) .and. &
     (iptout(3) == 0) .and. (iptout(4) == 0)) return
!
!  begin printed output
!
!  print first page of output
!
  if ( iptout(1) /= 0 ) then
    isubhd = 0
    call llhdr(page, wide, isubhd)
    call fitpt1(n, m, x, y, pv, sdpv, res, sdres, wt, ix, nnzw, &
      weight, iptout(1))
  end if
!
!  print plots
!
  if ( iptout(2) /= 0 ) then
    isubhd = 0
    call llhdr(page, wide, isubhd)
    call fitpt2 (sdres, pv, wt, n, nnzw, weight, res, rss)
  end if
!
!  print analysis of variance
!
  if (iptout(3) /= 0) then
    isubhd = 0
    call llhdr(page, wide, isubhd)
    call oanova(ysum, red, npar, rvar, nnzw, par1 )
  end if

  if (iptout(4) == 0) then
    return
  end if

  if (npar == 1) go to 450
  nc = nc - 1
  idf1 = nnzw - nc
  go to 50

  380 continue
  do i=1,nc
     t(i,i) = sqrt(t(i,1))
     do j=i,nc
        if ( i /= j ) then
          t(i,j) = t(i,j)*t(i,i)
        end if
     end do
  end do

  call strdi(t, npar, nc, det, 011, ier)

  if (ier == 0) go to 420
  write ( *,1140)
  par1(1:nc) = 0.0e0

  do i=1,nc
     t(i,i) = 0.0e0
  end do

  go to 450
  420 continue
  do i=1,nc
     sm = 0.0e0
     do k=i,nc
        sm = sm + t(i,k)*t(i,k)
     end do
     t(i,i) = sm
  end do
!
!  print page headings
!
  450 continue
  isubhd = 0
  call llhdr(page, wide, isubhd)
!
!  print variance covariance matrix
!
  call vcvout(npar, vcv, npar, .true.)

  write ( *,1030)
  if (npar > 1) write ( *,1040)
  write ( *,1050)
  if (npar > 1) write ( *,1060)
  write ( *, 1170)
  if (npar >= 2) then
     do i=1,nc
        sdc = sqrt(vcv(i,i))
        ratio = fplm
        probt = 0.0e0
        if (sdc > 0.0e0) ratio = par(i)/sdc
        if (sdc > 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 > 0.0e0) ratio1 = par1(i)/sdc1
        if (sdc1 > 0.0e0) &
           probt1 = (1.0e0 - cdft(abs(ratio1), nnzw-npar+1)) * 2.0e0
        write ( *,1070) i, par(i), sdc, ratio, probt, acc(i), &
           par1(i), sdc1, ratio1, probt1
    end do
  end if
  sdc = sqrt(vcv(npar,npar))
  ratio = fplm
  probt = 0.0e0
  if (sdc > 0.0e0) ratio = par(npar)/sdc
  if (sdc > 0.0e0) &
     probt = (1.0e0 - cdft(abs(ratio), nnzw-npar)) * 2.0e0
  write ( *,1070) npar, par(npar), sdc, ratio, probt, acc(npar)
  if (npar == 1) write ( *,1080) rsd
  if (npar > 1) write ( *,1080) rsd, rsd1
  write ( *,1090) nnzw, npar, idf
  if (npar > 1) write ( *,1100) nnzw, nc, idf1
  if (const) write ( *,1010) r2
  write ( *,1000) cond
  write ( *,1110)
  return

 1000 format (/' approximate condition number', 10x, g15.7)
 1010 format (/' multiple correlation coefficient squared   ', f7.4)
 1020 format (//' the values computed for the parameters are - '/(5x, &
     'par(', i3, ') = ', g15.7))
 1030 format (////1x, 25('-'), 1x, 'estimates from fit', 1x, 24('-'))
 1040 format ('+', 72x, 4('-'), 1x, &
     'estimates from fit omitting last predictor value', 1x, &
     4('-'))
 1050 format (/2x, 'estimated parameter', 7x, 'sd of par', 5x, &
     't(par=0)', 3x, 'prob(t)', 2x, 'acc dig*')
 1060 format ('+', 72x, 'estimated parameter', 7x, 'sd of par', 5x, &
     't(par=0)', 3x, 'prob(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, 'residual standard deviation   ', 9x, g15.7, 56x, &
     g15.7)
 1090 format (1x, 'based on degrees of freedom', 7x, i4, ' - ', i2, &
     ' = ', i4)
 1100 format ('+', 105x, i4, ' - ', i2, ' = ', i4)
 1110 format (//' * the number of correctly computed digits in each p', &
     'arameter usually differs by less than 1 from the value g', &
     'iven here.')
 1120 format (/' the program was unable to compute the variance', &
     '-covariance matrix.'/ &
     ' the design matrix is either nearly singular or very', &
     ' ill conditioned.'/ &
     ' check your input for errors.')
 1140 format ('0estimates for the standard deviation of the estimated', &
     'parameters omitting the last independent variable could'/ &
     ' not be computed.  the zeros printed for the estimates of t', &
     'he parameters, their standard deviations and their'/ &
     ' ratios for the fit omitting the last variable are meaningl', &
     'ess.')
 1150 format (/' the design matrix is singular', &
     ' to within machine precision.'/ &
     ' check the design matrix for a linear relationship', &
     ' between some of the columns.')
 1160 format (//1x, 11('*')/ 1x, '*  error  *'/ 1x, 11('*'))
 1170 format (' ')
 1180 format (/' the least squares fit of the data to the model is', &
     ' exact to within machine precision.'/ &
     ' statistical analysis is not possible.')
end
subroutine llsp ( y, xm, n, ndeg, res, ldstak )

!*****************************************************************************80
!
!! LLSP does an unweighted polynomial model least squares fit.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     integer ndeg
!        the degree of the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(1)
!        a dummy array for
!        the parameters  to be estimated.
!     real pv(1)
!        a dummy array for
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(1)
!        a dummy array for
!        the standard deviations of the predicted values.
!     real sdres(1)
!        a dummy array for
!        the standardized residuals.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        a dummy array for
!        the weights.
!     real xm(n,1)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     ldstak,n,ndeg
!
!  array arguments
  real &
     res(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     rsd
  integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,npar,nprt
  logical &
     save,weight
!
!  local arrays
  real &
     par(1),pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1)
  character &
     nmsub(6)*1
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr

!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s','p',' ',' '/

  weight = .false.
  save = .false.
  nprt = 1111
  lpar = 1
  lpv = 1
  lsdpv = 1
  lsdres = 1
  ivcv = 1
  lwt = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (//' the correct form of the call statement is'// &
     '       call llsp (y, x, n, ndeg, res, lsdtak)')
end
subroutine llsps ( y, xm, n, ndeg, res, ldstak, &
     nprt, lpar, par, npar, rsd, pv, sdpv, sdres, vcv, ivcv )

!*****************************************************************************80
!
!! LLSPS does an unweighted polynomial model least squares fit.
!
!  Discussion:
!
!    call for polynomial model least squares fit
!    no weights specified
!    full storage
!    user control of automatic printout
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     integer ndeg
!        the degree of the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(lpar)
!        the parameters  to be estimated.
!     real pv(n)
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(n)
!        the standard deviations of the predicted values.
!     real sdres(n)
!        the standardized residuals.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the weights (a dummy vector in the unweighted case).
!     real xm(n,1)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     rsd
  integer &
     ivcv,ldstak,lpar,n,ndeg,npar,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer lpv,lsdpv,lsdres,lwt
  logical &
     save,weight
!
!  local arrays
  real &
     wt(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external llcntp
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s','p','s',' '/

  weight = .false.
  save = .true.
  lpv = n
  lsdpv = n
  lsdres = n
  lwt = 1

  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)

  if (ierr /= 0 ) then
    write ( *,1000)
  end if

  return

 1000 format (//' 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
subroutine llspw ( y, wt, xm, n, ndeg, res, ldstak )

!*****************************************************************************80
!
!! LLSPW does a weighted polynomial model least squares fit.
!
!  Discussion:
!
!    call for polynomial model least squares fit
!    user supplied weights specified
!    no storage other than residuals
!    four pages automatic printout
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     integer ndeg
!        the degree of the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(1)
!        a dummy array for
!        the parameters  to be estimated.
!     real pv(1)
!        a dummy array for
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(1)
!        a dummy array for
!        the standard deviations of the predicted values.
!     real sdres(1)
!        a dummy array for
!        the standardized residuals.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        a dummy array for
!        the weights.
!     real xm(n,1)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     ldstak,n,ndeg
!
!  array arguments
  real &
     res(*),wt(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     rsd
  integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,npar,nprt
  logical &
     save,weight
!
!  local arrays
  real &
     par(1),pv(1),sdpv(1),sdres(1),vcv(1,1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external llcntp
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s','p','w',' '/

  weight = .true.
  save = .false.
  nprt = 1111
  lpar = 1
  lpv = 1
  lsdpv = 1
  lsdres = 1
  ivcv = 1
  lwt = n

  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)

  if (ierr /= 0) then
    write ( *,1000)
  end if

  return

 1000 format (//' the correct form of the call statement is'// &
     '       call llspw (y, wt, x, n, ndeg, res, lsdtak)')
end
subroutine llspws ( y, wt, xm, n, ndeg, res, ldstak, &
     nprt, lpar, par, npar, rsd, pv, sdpv, sdres, vcv, ivcv )

!*****************************************************************************80
!
!! LLSPWS computes a weighted polynomial model least squares fit.
!
!  Discussion:
!
!    call for polynomial model least squares fit
!    user supplied weights specified
!    full storage
!    user control of automatic printout
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     integer ndeg
!        the degree of the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(lpar)
!        the parameters  to be estimated.
!     real pv(n)
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(n)
!        the standard deviations of the predicted values.
!     real sdres(n)
!        the standardized residuals.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights (a dummy vector in the unweighted case).
!     real xm(n,1)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     rsd
  integer &
     ivcv,ldstak,lpar,n,ndeg,npar,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer lpv,lsdpv,lsdres,lwt
  logical &
     save,weight
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external llcntp
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s','p','w','s'/

  weight = .true.
  save = .true.
  lpv = n
  lsdpv = n
  lsdres = n
  lwt = n

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (//' 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
subroutine llss ( y, xm, n, ixm, npar, res, ldstak, &
     nprt, par, rsd, pv, sdpv, sdres, vcv, ivcv )

!*****************************************************************************80
!
!! LLSS computes an unweighted linear model least squares fit.
!
!  Discussion:
!
!    call for general linear model least squares fit
!    no weights specified
!    full storage
!    user control of automatic printout
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ixm
!        the first dimension of the matrix xm.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(npar)
!        the parameters  to be estimated.
!     real pv(n)
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(n)
!        the standard deviations of the predicted values.
!     real sdres(n)
!        the standardized residuals.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the weights (a dummy vector in the unweighted case).
!     real xm(ixm,npar)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  real &
     rsd
  integer &
     ivcv,ixm,ldstak,n,npar,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer lpar,lpv,lsdpv,lsdres,lwt
  logical &
     save,weight
!
!  local arrays
  real &
     wt(1)
  character &
     nmsub(6)*1
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s','s',' ',' '/

  weight = .false.
  save = .true.
  lpar = npar
  lpv = n
  lsdpv = n
  lsdres = n
  lwt = 1

  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)

  if ( ierr /= 0) then
    write ( *,1000)
  end if

  return

 1000 format (//' 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
subroutine llsw ( y, wt, xm, n, ixm, npar, res, ldstak )

!*****************************************************************************80
!
!! LLSW computes a weighted linear model least squares fit.
!
!  Discussion:
!
!    call for general linear model least squares fit
!    user supplied weights specified
!    no storage other than residuals
!    four pages automatic printout
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ixm
!        the first dimension of the matrix xm.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(1)
!        a dummy array for
!        the parameters  to be estimated.
!     real pv(1)
!        a dummy array for
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(1)
!        a dummy array for
!        the standard deviations of the predicted values.
!     real sdres(1)
!        a dummy array for
!        the standardized residuals.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        a dummy array for
!        the weights.
!     real xm(ixm,npar)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer &
     ixm,ldstak,n,npar
!
!  array arguments
  real &
     res(*),wt(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     rsd
  integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,nprt
  logical &
     save,weight
!
!  local arrays
  real &
     par(1),pv(1),sdpv(1),sdres(1),vcv(1,1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external llcntg
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr

  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s','w',' ',' '/

  weight = .true.
  save = .false.
  nprt = 1111
  lpar = 1
  lpv = 1
  lsdpv = 1
  lsdres = 1
  ivcv = 1
  lwt = n

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (//' the correct form of the call statement is'// &
     '       call llsw (y, wt, xm, n, ixm, npar, res, lsdtak)')
end
subroutine llsws ( y, wt, xm, n, ixm, npar, res, ldstak, &
     nprt, par, rsd, pv, sdpv, sdres, vcv, ivcv )

!*****************************************************************************80
!
!! LLSWS performs a general linear model weighted least squares fit.
!
!  Discussion:
!
!    call for general linear model least squares fit
!    user supplied weights specified
!    full storage
!    user control of automatic printout
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value designating whether any errors were
!        detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ivcv
!        the first dimension of the matrix vcv.
!     integer ixm
!        the first dimension of the matrix xm.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpar
!        the actual length of the vector p.
!     integer lpv
!        the actual length of the vector pv.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters.
!     integer nprt
!        the indicator variable used to designate the amount of
!        printed output.
!     real par(npar)
!        the parameters  to be estimated.
!     real pv(n)
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals are to ve saved (true) or not (false).
!     real sdpv(n)
!        the standard deviations of the predicted values.
!     real sdres(n)
!        the standardized residuals.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights (a dummy vector in the unweighted case).
!     real xm(ixm,npar)
!        the independent variable.
!     real y(n)
!        the dependent variable.
!
!
  implicit none

  real &
     rsd
  integer &
     ivcv,ixm,ldstak,n,npar,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer lpar,lpv,lsdpv,lsdres,lwt
  logical &
     save,weight
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external llcntg
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr

  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'l','l','s','w','s',' '/

  weight = .true.
  save = .true.
  lpar = npar
  lpv = n
  lsdpv = n
  lsdres = n
  lwt = n

  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)

  if (ierr /= 1) return

  write ( *,1000)
  return

 1000 format (//' 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
subroutine lmstep ( d, g, ierr, ipivot, ka, p, qtr, r, step, v, w )

!***********************************************************************
!
!! LMSTEP computes a Levenberg-Marquardt step by More-Hebden techniques.
!
!  Discussion:
!
!    Given the R matrix from the QR decomposition of a jacobian
!    matrix, J, as well as Q' times the corresponding
!    residual vector, RESID, this subroutine computes a Levenberg-
!    Marquardt step of approximate length V(RADIUS) by the More
!    technique.
!
!    If it is desired to recompute step using a different value of
!    V(RADIUS), then this routine may be restarted by calling it
!    with all parameters unchanged except V(RADIUS).  This explains
!    why many parameters are listed as I/O.  On an initial call
!    with KA = -1, the caller need only have initialized D, G, KA, P,
!    QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), and V(RAD0).
!
!    This code implements the step computation scheme described in
!    refs. 2 and 4.  Fast Givens transformations (see reference 3,
!    pages 60-62) are used to compute step with a nonzero Marquardt
!    parameter.
!
!    A special case occurs if J is nearly singular and V(RADIUS)
!    is sufficiently large.  In this case the step returned is such
!    that  twonorm(R)**2 - twonorm(R - J * STEP)**2  differs from its
!    optimal value by less than V(EPSLON) times this optimal value,
!    where J and R denote the original jacobian and residual.  See
!    reference 2 for more details.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
!    David Gay,
!    Computing Optimal Locally Constrained Steps,
!    SIAM Journal on Scientific and Statistical Computing,
!    Volume 2, Number 2, pages 186-197, 1981.
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    Prentice Hall, 1974.
!
!    Jorge More,
!    The Levenberg-Marquardt Algorithm, Implementation and Theory,
!    in Springer Lecture Notes in Mathematics, Number 630,
!    edited by G A Watson,
!    Springer Verlag, Berlin and New York, pages 105-116, 1978.
!
!  Parameters:
!
!    Input, real D(P), the scale vector.
!
!    Input, real G(P), the gradient vector J'*R.
!
!   ierr (i/o) = return code from QRFACT or QRFGS -- 0 means r has
!             full rank.
!
! ipivot (i/o) = permutation array from QRFACT or QRFGS, which compute
!             qr decompositions with column pivoting.
!
!     ka (i/o).  ka < 0 on input means this is the first call on
!             lmstep for the current r and qtr.  on output ka con-
!             tains the number of Hebden iterations needed to determine
!             step.  ka = 0 means a Gauss-Newton step.
!
!      p (in)  = number of parameters.
!
!    qtr (in)  = Q' * residual.
!
!      r (in)  = the R matrix, stored compactly by columns.
!
!   step (out) = the Levenberg-Marquardt step computed.
!
!      v (i/o) contains various constants and variables described below.
!
!      w (i/o) = workspace of length p*(p+5)/2 + 4.
!
!  entries in v
!
! v(dgnorm) (i/o) = 2-norm of (d**-1)*g.
! v(dstnrm) (i/o) = 2-norm of d * step.
! v(dst0)   (i/o) = 2-norm of Gauss-Newton step (for nonsing. j).
! v(epslon) (in) = max. relative error allowed in twonorm(r)**2 minus
!             twonorm(r - j * step)**2.  (see algorithm notes below.)
! v(gtstep) (out) = inner product between G and STEP.
! v(nreduc) (out) = half the reduction in the sum of squares predicted
!             for a Gauss-Newton step.
! v(phmnfc) (in)  = tol. (together with v(phmxfc)) for accepting step
!             (More's sigma).  the error v(dstnrm) - v(radius) must lie
!             between v(phmnfc)*v(radius) and v(phmxfc)*v(radius).
! v(phmxfc) (in)  (see v(phmnfc).)
! v(preduc) (out) = half the reduction in the sum of squares predicted
!             by the step returned.
! v(radius) (in)  = radius of current (scaled) trust region.
! v(rad0)   (i/o) = value of v(radius) from previous call.
! v(STPPAR) (i/o) = Marquardt parameter (or its negative if the special
!             case mentioned below in the algorithm notes occurs).
!
  implicit none

  integer p

  real a
  real adi
  real alphak
  real b
  real d(p)
  real d1
  real d2
  real, parameter :: dfac = 256.0E+00
  real dfacsq
  integer, parameter :: dgnorm = 1
  real dotprd
  real dst
  integer, parameter :: dst0 = 3
  integer, parameter ::dstnrm = 2
  integer dstsav
  real dtol
  integer, parameter :: epslon = 19
  real g(p)
  integer i
  integer i1
  integer ierr
  integer ipivot(p)
  integer j1
  integer k
  integer ka
  integer kalim
  integer l
  real lk
  integer lk0
  real oldphi
  real phi
  real phimax
  real phimin
  integer phipin
  integer pp1o2
  real psifac
  real qtr(p)
  real r(*)
  real rad
  integer, parameter :: rad0 = 9
  integer res
  integer res0
  integer rmat
  integer rmat0
  real si
  real sj
  real sqrtak
  real step(p)
  integer, parameter :: stppar = 5
  real t
  real twopsi
  real uk
  integer uk0
  real v(21)
  real v2norm
  real w(p*(p+5)/2 + 4)
  real wl
!
!  subscripts for v
!
      integer gtstep, nreduc, phmnfc, &
              phmxfc, preduc, radius

     parameter ( gtstep=4, nreduc=6, phmnfc=20 )
    parameter ( phmxfc=21, preduc=7, radius=8 )
!
!  For use in recomputing STEP, the final values of LK and UK,
!  the inverse derivative of More's PHI at 0 (for nonsingular J)
!  and the value returned as V(DSTNRM) are stored at W(LK0),
!  W(UK0), W(PHIPIN), and W(DSTSAV) respectively.
!
  lk0 = p + 1
  phipin = lk0 + 1
  uk0 = phipin + 1
  dstsav = uk0 + 1
  rmat0 = dstsav
!
!  A copy of the R matrix from the QR decomposition of J is
!  stored in W starting at W(RMAT), and a copy of the residual
!  vector is stored in W starting at W(RES).  The loops below
!  that update the QR decomposition for a nonzero Marquardt parameter
!  work on these copies.
!
  rmat = rmat0 + 1
  pp1o2 = ( p * ( p + 1 ) ) / 2
  res0 = pp1o2 + rmat0
  res = res0 + 1
  rad = v(radius)
  if ( 0.0E+00 < rad ) then
    psifac = v(epslon) &
      / ( ( 8.0E+00 * ( v(phmnfc) + 1.0E+00 ) + 3.0E+00 ) * rad**2 )
  end if
  phimax = v(phmxfc) * rad
  phimin = v(phmnfc) * rad
!
!  DTOL and DFAC are used in rescaling the fast Givens
!  representation of the updated QR decomposition.
!
  dtol = 1.0E+00 / dfac
  dfacsq = dfac * dfac
!
!  OLDPHI is used to detect limits of numerical accuracy.  If
!  we recompute STEP and it does not change, then we accept it.
!
  oldphi = 0.0E+00
  lk = 0.0E+00
  uk = 0.0E+00
  kalim = ka + 12
!
!  Start or restart, depending on KA.
!
  if ( 0 < ka ) then
    go to 370
  end if
!
!  Fresh start.  Compute V(NREDUC).
!
  if ( ka < 0 ) then
    ka = 0
    kalim = 12
    k = p
    if ( ierr /= 0 ) then
      k = abs ( ierr ) - 1
    end if
    v(nreduc) = 0.5E+00 * dotprd ( k, qtr, qtr )
  end if
!
!  Set up to try initial Gauss-Newton step.
!
 20   continue

  v(dst0) = -1.0E+00
!
!  Compute Gauss-Newton step.
!
!  Note that the R matrix is stored compactly by columns in
!  R(1), R(2), R(3), ...  It is the transpose of a
!  lower triangular matrix stored compactly by rows, and we
!  treat it as such when using LITVMU and LIVMUL.
!
  if ( ierr == 0 ) then

    call litvmu ( p, w, r, qtr )
!
!  Temporarily store permuted -D * STEP in STEP.
!
    do i = 1, p
      j1 = ipivot(i)
      step(i) = d(j1) * w(i)
    end do

    dst = v2norm ( p, step )
    v(dst0) = dst
    phi = dst - rad

    if ( phi <= phimax ) then
      go to 410
    end if
!
!  If this is a restart, go to 110.
!
    if ( 0 < ka ) then
      go to 110
    end if
!
!  Gauss-Newton step was unacceptable.  Compute L0.
!
    do i = 1, p
      j1 = ipivot(i)
      step(i) = d(j1) * ( step(i) / dst )
    end do

    call livmul ( p, step, r, step )
    t = 1.0E+00 / v2norm ( p, step )
    w(phipin) = ( t / dst ) * t
    lk = phi * w(phipin)

  end if
!
!  Compute U0.
!
  w(1:p) = g(1:p) / d(1:p)
  v(dgnorm) = v2norm ( p, w )
  uk = v(dgnorm) / rad
!
!  Special case.  RAD <= 0 or (G = 0 and J is singular).
!
  if ( uk <= 0.0E+00 ) then
    v(stppar) = 0.0E+00
    dst = 0.0E+00
    lk = 0.0E+00
    uk = 0.0E+00
    v(gtstep) = 0.0E+00
    v(preduc) = 0.0E+00
    step(1:p) = 0.0E+00
    v(dstnrm) = dst
    w(dstsav) = dst
    w(lk0) = lk
    w(uk0) = uk
    v(rad0) = rad
    return
  end if
!
!  ALPHAK will be used as the current Marquardt parameter.  We
!  use More's scheme for initializing it.
!
  alphak = abs ( v(stppar) ) * v(rad0) / rad
!
!  Top of loop.  Increment KA, copy R to RMAT, QTR to RES.
!
110  continue

  ka = ka + 1
  w(rmat:rmat+pp1o2-1) = r(1:pp1o2)
  w(res:res+p-1) = qtr(1:p)
!
!  Safeguard ALPHAK and initialize fast Givens scale vector.
!
      if ( alphak <= 0.0E+00 .or. alphak < lk .or. uk <= alphak ) then
        alphak = uk * max ( 0.001E+00, sqrt ( lk / uk ) )
      end if

      sqrtak = sqrt(alphak)
      w(1:p) = 1.0E+00
!
!  Add ALPHAK * D and update QR decomposition using fast Givens transform.
!
      do i = 1, p
!
!  Generate, apply first Givens transformation for row I of ALPHAK * D.
!  Use STEP to store temporary row.
!
         l = ( i * ( i + 1 ) ) / 2 + rmat0
         wl = w(l)
         d2 = 1.0E+00
         d1 = w(i)
         j1 = ipivot(i)
         adi = sqrtak*d(j1)

         if ( abs(wl) <= adi ) then
           go to 150
         end if

 130     continue

         a = adi / wl
         b = d2 * a / d1
         t = a * b + 1.0E+00

         if ( t <= 2.5E+00 ) then

           w(i) = d1 / t
           d2 = d2 / t
           w(l) = t * wl
           a = -a
           do j1 = i, p
              l = l + j1
              step(j1) = a * w(l)
           end do
           go to 170

         end if

 150     continue

         b = wl / adi
         a = d1 * b / d2
         t = a * b + 1.0E+00

         if ( 2.5E+00 < t ) then
           go to 130
         end if

         w(i) = d2 / t
         d2 = d1 / t
         w(l) = t * adi
         do j1 = i, p
              l = l + j1
              wl = w(l)
              step(j1) = -wl
              w(l) = a * wl
         end do

 170     continue

         if ( i == p ) then
           exit
         end if
!
!  Now use Givens transformations to zero elements of temporary row.
!
         do i1 = i + 1, p
              l = ( i1 * ( i1 + 1 ) ) / 2 + rmat0
              wl = w(l)
              si = step(i1-1)
              d1 = w(i1)
!
!  Rescale row I1 if necessary.
!
              if ( d1 < dtol ) then
                d1 = d1 * dfacsq
                wl = wl / dfac
                k = l
                do j1 = i1, p
                  k = k + j1
                  w(k) = w(k) / dfac
                end do
              end if
!
!  Use Givens transformations to zero next element of temporary row.
!
              if ( abs ( wl ) < abs ( si ) ) then
                go to 220
              end if

              if ( si == 0.0E+00 ) then
                go to 260
              end if

 200          continue

              a = si / wl
              b = d2 * a / d1
              t = a * b + 1.0E+00

              if ( t <= 2.5E+00 ) then

                w(l) = t * wl
                w(i1) = d1 / t
                d2 = d2 / t
                do j1 = i1, p
                   l = l + j1
                   wl = w(l)
                   sj = step(j1)
                   w(l) = wl + b * sj
                   step(j1) = sj - a*wl
                end do

                go to 240

              end if

 220          b = wl / si
              a = d1 * b / d2
              t = a * b + 1.0E+00

              if ( 2.5E+00 < t ) then
                go to 200
              end if

              w(i1) = d2 / t
              d2 = d1 / t
              w(l) = t * si
              do j1 = i1, p
                   l = l + j1
                   wl = w(l)
                   sj = step(j1)
                   w(l) = a * wl + sj
                   step(j1) = b * sj - wl
              end do
!
!  Rescale temporary row if necessary.
!
 240          continue

              if ( d2 < dtol ) then
                   d2 = d2*dfacsq
                   step(i1:p) = step(i1:p) / dfac
              end if

 260          continue

        end do
      end do
!
!  Compute step.
!
      call litvmu ( p, w(res), w(rmat), w(res) )
!
!  Recover STEP and store permuted -D * STEP at W(RES).
!
      do i = 1, p
         j1 = ipivot(i)
         k = res0 + i
         t = w(k)
         step(j1) = -t
         w(k) = t * d(j1)
      end do

      dst = v2norm ( p, w(res) )
      phi = dst - rad

      if ( phi <= phimax .and. phimin <= phi ) then
        go to 430
      end if

      if ( oldphi == phi ) then
        go to 430
      end if

      oldphi = phi
!
!  Check for and handle special case.
!
      if ( phi <= 0.0E+00 ) then

        if ( kalim <= ka ) then
          go to 430
        end if

        twopsi = alphak * dst * dst - dotprd ( p, step, g )

        if ( alphak < twopsi * psifac ) then
          v(stppar) = -alphak
          go to 440
        end if

      end if

      if ( phi < 0.0E+00 ) then
        uk = alphak
      end if

 320  continue

      do i = 1, p
         j1 = ipivot(i)
         k = res0 + i
         step(i) = d(j1) * ( w(k) / dst )
      end do

      call livmul ( p, step, w(rmat), step )
      step(1:p) = step(1:p) / sqrt ( w(1:p) )
      t = 1.0E+00 / v2norm ( p, step )
      alphak = alphak + t * phi * t / rad
      lk = max ( lk, alphak )
      go to 110
!
!  Restart.
!
 370  continue

      lk = w(lk0)
      uk = w(uk0)

      if ( 0.0E+00 < v(dst0) .and. v(dst0) - rad <= phimax ) then
        go to 20
      end if

      alphak = abs ( v(stppar) )
      dst = w(dstsav)
      phi = dst - rad
      t = v(dgnorm) / rad
!
!  Smaller radius.
!
      if ( rad <= v(rad0) ) then

         uk = t

         if ( alphak <= 0.0E+00 ) then
           lk = 0.0E+00
         end if

         if ( 0.0E+00 < v(dst0) ) then
           lk = max ( lk, (v(dst0)-rad)*w(phipin) )
         end if

         if ( phi < 0.0E+00 ) then
           uk = min ( uk, alphak )
         end if

         go to 320

      end if
!
!  Bigger radius.
!
      if ( alphak <= 0.0E+00 .or. t < uk ) then
        uk = t
      end if

      if ( 0.0E+00 < v(dst0) ) then
        lk = max ( lk, (v(dst0)-rad)*w(phipin) )
      else
        lk = 0.0E+00
      end if

      if ( phi < 0.0E+00 ) then
        uk = min ( uk, alphak )
      end if

      go to 320
!
!  Acceptable Gauss-Newton step.  Recover step from W.
!
 410  continue

      alphak = 0.0E+00
      do i = 1, p
         j1 = ipivot(i)
         step(j1) = -w(i)
      end do
!
!  Save values for use in a possible restart.
!
 430  continue

  v(stppar) = alphak

 440  continue

  v(gtstep) = dotprd ( p, step, g )
  v(preduc) = 0.5E+00 * ( alphak * dst * dst - v(gtstep) )
  v(dstnrm) = dst
  w(dstsav) = dst
  w(lk0) = lk
  w(uk0) = uk
  v(rad0) = rad

  return
end
subroutine loglmt ( ilogy, ymn, ymx, ylabel, numrow, istep, dely, &
    ywidth, nlably, ydmn, ydmx )

!*****************************************************************************80
!
!! LOGLMT adjusts plot limits for log plots, and computes log axis labels.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real dely
!     integer ilogy, istep, iyn, iynlog, iyx, iyxlog, j, k
!     integer nlably, numrow
!     real ylabel(20)
!        the y-axis lables.
!     real ydmn, ydmx
!        the y-axis data limits actually used.
!     real ymn, ymx
!        the y-axis plot limits actually used.
!     real ynlog, ywidth, yxlog
!
  implicit none

  real &
     dely,ydmn,ydmx,ymn,ymx,ywidth
  integer &
     ilogy,istep,nlably,numrow
!
!  array arguments
  real &
     ylabel(20)

  real &
     ynlog,yxlog
  integer &
     iyn,iynlog,iyx,iyxlog,j,k

  if (ilogy == 0) then

    ydmn = ymn
    ydmx = ymx
!
!  determine the value of a division
!
    dely=ymx-ymn
    ywidth=dely/ real (numrow-1)
!
!  compute evenly spaced labels for non-log axis
!
    nlably = 0
    do j = 1, numrow, istep
      nlably = nlably + 1
      ylabel(nlably) = ymx+ real ( 1 - j ) * ywidth
    end do

      if (mod(numrow,istep) == 1) ylabel(nlably) = ymn
      if (ymx == (-ymn) .and. mod(nlably,2) == 1) then
         ylabel(nlably/2+1) = 0.0
      end if
  else

    ydmn = log10(ymn)
    ydmx = log10(ymx)
!
!  adjust axis limits for log axis if necessary
!
    yxlog=log10(ymx)
    iyxlog = int ( yxlog )
    if (ymx<1.0e0) iyxlog=iyxlog-1
    ynlog=log10(ymn)
    if ((yxlog-ynlog) <= 0.92082e0) then
!
!  range is less than .9 decades
!
      iynlog = int ( ynlog )
      if (ymn<1.0e0) iynlog=iynlog-1
      if (iyxlog <= iynlog) then
!
!  values fall in the same decade
!
        ynlog = real ( iynlog )
        yxlog = ynlog+1.0e0
        iyxlog = int ( yxlog )
      else
!
!  values fall into two decades
!
        iyn = nint(ymn/(10.0e0**iynlog))
        ynlog = min(log10( real ( iyn ) *(10.0e0**iynlog)),ynlog)
        yxlog = ynlog+1.0e0
        iyxlog = int ( yxlog )
      end if
    end if
    ymx=yxlog
    ymn=ynlog
!
!  determine the value of a division
!
    dely=ymx-ymn
    ywidth=dely / real(numrow-1)
!
!  compute axis labels
!
    ylabel(1)=10.0e0**yxlog
    iyx = int ( ylabel(1) / ( 10.0e0**iyxlog ) )
    k=2
    if (yxlog-ynlog > 3.0e0) k=5
    if (yxlog-ynlog > 6.0e0) k=10

    nlably = 1

    if (yxlog-ynlog <= 12.0e0) then
!
!  set nice labels
!
      if (k == 10) iyx=1
      if (iyx /= 1.and.(iyx-((iyx/k)*k)) /= 0) iyx=((iyx/k)*k)
      if (iyx <= 1) then
        iyx=10
        iyxlog=iyxlog-1
      end if

      if (ylabel(1)-real ( iyx ) *(10.0e0**iyxlog) > 0.0e0 .and. &
       yxlog-(yxlog-ynlog)/(2.0e0*real(numrow-1)) > &
       log10(real(iyx))+real ( iyxlog )) then
        iyx=iyx+k
      end if

      iyx=iyx-k
      if (iyx <= 0) then
        iyx=10
        iyxlog=iyxlog-1
      end if

      do j=2,20

         nlably=nlably+1
         ylabel(nlably) = real ( iyx ) * ( 10.0e0**iyxlog )

         if (ylabel(nlably) <= 10.0e0**ynlog) then
           exit
         end if

         iyx=iyx-k

         if (iyx <= 0) then
           iyx=10
           iyxlog=iyxlog-1
         end if

      end do

       ylabel(nlably)=10.0e0**ynlog
    else
!
!  compute evenly spaced labels
!
      do j = istep, numrow, istep
        nlably = nlably + 1
        ylabel(nlably) = 10.0e0**(ymx+real ( 1  - j ) * ywidth )
      end do

    end if

  end if

  return
end
subroutine lopass ( y, n, fc, k, hlp, yf, nyf )

!*****************************************************************************80
!
!! LOPASS carries out a low-pass filtering of a series.
!
!  Discussion:
!
!    this subroutine carries out low-pass filtering of the
!    series.  the filter is the k-term
!    least squares approximation to the cutoff filter
!    with cutof frequency fc.  its transfer function
!    has a transition band of width delta surrounding fc,
!    where delta = 4*pi/k.
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!
!     variable definitions (alphabetically)
!
!     logical err01, err02, err03, err04, err05
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real fc
!        the user supplied cutoff frequency.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     real hlp(k)
!        the array in which the -ideal- high pass filter coefficients
!        will be returned.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer k
!        the number of filter terms to be computed.
!     character*1 lfc(8), lk(8), ln(8)
!        the array containing the names of the variables fc, k and n.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  implicit none

  real &
     fc
  integer &
     k,n,nyf
!
!  array arguments
  real &
     hlp(*),y(*),yf(*)
!
!  scalars in common
  integer &
     ierr
!
!
  logical &
     err01,err02,err03,err04,err05,head
!
!  local arrays
  character &
     lfc(8)*1,lk(8)*1,ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,eisii,eriodd,ersii,erslfs,fltsl,lpflt
!
!  common blocks
  common /errchk/ierr

!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  call ersii(nmsub, lfc, fc, 0.0e0, 0.5e0, 2, head, err02, lfc, lfc)

  call eisii(nmsub, lk, k, 1, n, 2, head, err03, lk, lk)

  call eriodd(nmsub, lk, k, 1, head, err04)

  if (err01 .or. err02 .or. err03 .or. err04) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call erslfs(nmsub, fc, k, head, err05)

  if ( err05) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call lpflt (fc, k, hlp)

  call fltsl (y, n, k, hlp, yf, nyf)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call lopass (y, n, fc, k, hlp, yf, nyf)')
end
subroutine lpcoef ( fc, k, hlp )

!*****************************************************************************80
!
!! LPCOEF computes a least squares approximation to an ideal low pass filter.
!
!  Discussion:
!
!    This subroutine computes the k-term least squares
!    approximation to an -ideal- low pass filter
!    with cutof frequency fc.  its transfer function
!    has a transition band of width delta surrounding fc,
!    where delta = 4*pi/k.
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!
!     variable definitions (alphabetically)
!
!     logical err01, err02, err03, err04
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real fc
!        the user supplied cutoff frequency.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     real hlp(k)
!        the array in which the -ideal- low pass filter coefficients
!        will be returned.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer k
!        the number of filter terms to be computed.
!     character*1 lfc(8), lk(8)
!        the array containing the names of the variables fc and k.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!
  implicit none

  real &
     fc
  integer &
     k
!
!  array arguments
  real &
     hlp(*)
!
!  scalars in common
  integer &
     ierr

  logical &
     err01,err02,err03,err04,head
!
!  local arrays
  character &
     lfc(8)*1,lk(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisii,eriodd,ersii,erslfs,lpflt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  call ersii(nmsub, lfc, fc, 0.0e0, 0.5e0, 2, head, err01, lfc, lfc)

  call eisii(nmsub, lk, k, 1, k, 2, head, err02, lk, lk)

  call eriodd(nmsub, lk, k, 1, head, err03)

  if (err01 .or. err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call erslfs ( nmsub, fc, k, head, err04 )

  if (err04) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call lpflt (fc, k, hlp)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call lpcoef (fc, k, hlp)')
end
subroutine lpflt ( fc, k, hlp )

!*****************************************************************************80
!
!! LPFLT computes the low-pass filter coefficients.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real arg, con
!        variables used in the computation of the low pass filter
!        coefficients.
!     real fc
!        the cutoff frequency used for the low pass filter.
!     real hlp(k)
!        the array in which the input low pass filter coefficients
!        are stored.
!     integer i
!        an index variable.
!     integer ihm, ihp
!        index variables for symmetric locations around the midpoint
!        of the filter.
!     integer k
!        the number of terms in the filter.
!     integer khalf
!        the value of the midpoint of k minus 1.
!     integer kmid
!        the midpoint of the filter.
!     real pi
!        the value of pi.
!     real sum
!        a value used for summing.
!
  implicit none

  real &
     fc
  integer &
     k
!
!  array arguments
  real &
     hlp(k)

  real &
     arg,con,pi,sum
  integer &
     i,ihm,ihp,khalf,kmid
!
!  external subroutines
  external getpi

  call getpi ( pi )

  kmid = ( k + 1 ) / 2

  hlp(kmid) = 1.0e0

  if ( k == 1 ) then
    return
  end if

  hlp(kmid) = 2.0e0 * fc
  con = 2.0e0 * pi / real ( k )
  sum = hlp(kmid)

  khalf = ( k - 1 ) / 2

  do i = 1, khalf
     arg = real ( i ) * con
     ihp = kmid + i
     hlp(ihp) = sin( real ( i ) * fc * 2.0e0 * pi ) * sin(arg) / &
        ( real( i ) * pi * arg)
     ihm = kmid - i
     hlp(ihm) = hlp(ihp)
     sum = sum + hlp(ihm) + hlp(ihp)
  end do

  hlp(1:k) = hlp(1:k) / sum

  return
end
function lsame ( ca, cb )

!*****************************************************************************80
!
!! LSAME returns TRUE if CA is the same letter as CB regardless of case.
!
!  Modified:
!
!    16 May 2005
!
!  Author:
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, character CA, CB, the character to compare.
!
!    Output, logical LSAME, is TRUE if the characters are equal,
!    disregarding case.
!
  implicit none

  character ca
  character cb
  integer inta
  integer intb
  logical lsame
  integer zcode
!
!  Test if the characters are equal
!
  lsame = ( ca == cb )

  if ( lsame ) then
    return
  end if
!
!  Now test for equivalence if both characters are alphabetic.
!
  zcode = ichar ( 'Z' )
!
!  Use 'Z' rather than 'A' so that ASCII can be detected on Prime
!  machines, on which ICHAR returns a value with bit 8 set.
!  ICHAR('A') on Prime machines returns 193 which is the same as
!  ICHAR('A') on an EBCDIC machine.
!
  inta = ichar ( ca )
  intb = ichar ( cb )

  if ( zcode == 90 .or. zcode == 122 ) then
!
!  ASCII is assumed - zcode is the ASCII code of either lower or
!  upper case 'Z'.
!
    if ( 97 <= inta .and. inta <= 122 ) then
      inta = inta - 32
    end if

    if ( 97 <= intb .and. intb <= 122 ) then
      intb = intb - 32
    end if

  else if ( zcode == 233 .or. zcode == 169 ) then
!
!  EBCDIC is assumed - zcode is the EBCDIC code of either lower or
!  upper case 'Z'.
!
    if ( 129 <= inta .and. inta <= 137 .or. &
         145 <= inta .and. inta <= 153 .or. &
         162 <= inta .and. inta <= 169 ) then
      inta = inta + 64
    end if

    if ( 129 <= intb .and. intb <= 137 .or. &
         145 <= intb .and. intb <= 153 .or. &
         162 <= intb .and. intb <= 169 ) then
      intb = intb + 64
    end if

  else if ( zcode == 218 .or. zcode == 250 ) then
!
!  ASCII is assumed, on Prime machines - zcode is the ASCII code
!  plus 128 of either lower or upper case 'Z'.
!
    if ( 225 <= inta .and. inta <= 250 ) then
      inta = inta - 32
    end if

    if ( 225 <= intb .and. intb <= 250 ) then
      intb = intb - 32
    end if

  end if

  lsame = ( inta == intb )

  return
end
subroutine lsqrt ( n1, n, l, a, irc )

!***********************************************************************
!
!! LSQRT computes the Cholesky factor of a lower triangular matrix.
!
!  Discussion:
!
!    Compute rows N1 through N of the Cholesky factor L of
!    A = L * L', where L and the lower triangle of A are both
!    stored compactly by rows, and may occupy the same storage.
!
!    IRC = 0 means all went well.  IRC = J means the leading
!    principal J x J submatrix of A is not positive definite,
!    and L(J*(J+1)/2) contains the nonpositive reduced J-th diagonal.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer N1, N, the first and last rows to be computed.
!
!    Output, real L((N*(N+1))/2), contains rows N1 through N of the
!    Cholesky factorization of A, stored compactly by rows as a lower
!    triangular matrix.
!
!    Input, real A((N*(N+1))/2), the matrix whose Cholesky factorization
!    is desired.
!
!    Output, integer IRC, an error flag.  If IRC = 0, then the factorization
!    was carried out successfully.  Otherwise, the principal J x J subminor
!    of A was not positive definite.
!
  implicit none

  integer n

  real a(n*(n+1)/2)
  integer i
  integer i0
  integer ij
  integer ik
  integer irc
  integer j
  integer j0
  integer jk
  integer k
  real l(n*(n+1)/2)
  integer n1
  real t
  real td

  i0 = ( n1 * ( n1 - 1 ) ) / 2

  do i = n1, n

    td = 0.0E+00
    j0 = 0

    do j = 1, i - 1

      t = 0.0E+00

      do k = 1, j - 1
        ik = i0 + k
        jk = j0 + k
        t = t + l(ik) * l(jk)
      end do

      ij = i0 + j
      j0 = j0 + j
      t = ( a(ij) - t ) / l(j0)
      l(ij) = t
      td = td + t * t

    end do

    i0 = i0 + i
    t = a(i0) - td

    if ( t <= 0.0E+00 ) then
      l(i0) = t
      irc = i
      return
    end if

    l(i0) = sqrt ( t )

  end do

  irc = 0

  return
end
function lstlag ( nlppa, lagmax, lacov )

!*****************************************************************************80
!
!! LSTLAG finds the last computable lag value.
!
!  Discussion:
!
!    This routine finds the lag value of the last autocovariance
!    computed before one could not be computed due to missing data.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     lacov,lagmax
  integer lstlag
!
!  array arguments
  integer &
     nlppa(lacov)

  integer &
     lag
!
!     variable definitions (alphabetically)
!
!     integer lacov
!        the length of the vector acov.
!     integer lag
!        the indexing variable indicating the lag value of the
!        autocorrelation.
!     integer nlppa(lacov)
!        the array containing the numbers of lagged product pairs
!        used to compute the acvf at each lag.
!
!     find the last autocorrelation to be computed before
!     one could not be computed due to missing data
!
  lstlag = -1
  if (nlppa(1) <= 0) return

  do lag = 1, lagmax
    if (nlppa(lag + 1) < 1) then
      lstlag = lag - 1
      return
    end if
  end do

  lstlag = lagmax

  return
end
subroutine lstvcf ( n, vec, lmask, mask )

!*****************************************************************************80
!
!! LSTVCF prints N elements of a masked array.
!
!  Discussion:
!
!    this subroutine prints the first n elements of the vector
!    vec.  the i th element of vec is identified with the index
!    of the i th zero element of mask.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer imask
!        index in mask.
!     integer imax, imin
!        the largest and smallest indices in vec of the elements to be
!        printed.
!     integer index
!        the index of the value to be printed.
!     integer indw(10)
!        a work vector for the indices to be printed for vec.
!     integer jmax
!        index in indw of the largest index to be printed for vec.
!     integer lmask
!        the length of mask.  lmask  >=  n.
!     integer mask(lmask)
!        mask vector for vec.  the index of the ith element of mask
!        equal to zero is the label in the output of the ith element
!        of vec.
!     integer n
!        the number of values to be printed in the input vector.
!     integer nperl
!        the number of values to be printed per line.
!     real vec(n)
!        the vector of values to be printed.
!
  implicit none

  integer &
     lmask,n
!
!  array arguments
  real &
     vec(n)
  integer &
     mask(lmask)
!
!
  integer &
     i,imask,imax,imin,index,j,jmax,nperl
!
!  local arrays
  integer &
     indw(10)
!
!  external functions
  integer &
     inperl
  external inperl
!
!  external subroutines

  nperl = inperl ( )
!
!   note - inperl( ) is assumed to be at most 10.0e0  if greater,
!   increase the dimension of indw.
!
  imask = 0

  do i = 1, n, nperl

    imin = i
    imax = min(i+nperl-1, n)
    jmax = min(n - imin + 1, nperl)

    do j = 1, jmax

      do

        if (imask  >=  lmask) then
          write ( *, 1030 )
          return
        end if

        imask = imask + 1

        if (mask(imask)  ==  0) then
          exit
        end if

      end do

      indw(j) = imask

    end do

    write ( *, 1010) (indw(index), index = 1, jmax)
    write ( *, 1020) (vec(index), index = imin, imax)

  end do

  return

 1010 format(10x, 'index', i5, 6i15)
 1020 format(10x, 'value', 7(1x, g14.7)/)
 1030 format (/' error in starpac.  lstvec tried to access more', &
     ' elements than exist in mask.')

end
subroutine lstvec ( n, vec )

!*****************************************************************************80
!
!! LSTVEC prints indices and values of a real vector.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index variable
!     integer imax, imin
!        the largest and smallest index value to be printed on each
!        line.
!     integer index
!        the index value to be printed.
!     integer n
!        the number of values to be printed in the input vector.
!     integer nperl
!        the number of values to be printed per line.
!     real vec(n)
!        the vector of values to be printed.
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     vec(n)

  integer &
     i,imax,imin,index,nperl
!
!  external functions
  integer &
     inperl
  external inperl
!
!  external subroutines

  nperl = inperl( )

  do i = 1, n, nperl
     imin = i
     imax = min(i+nperl-1, n)
     write ( *, 1010) (index, index = imin, imax)
     write ( *, 1020) (vec(index), index = imin, imax)
  end do

  return

 1010 format(10x, 'index', i5, 6i15)
 1020 format(10x, 'value', 7(1x, g14.7)/)

end
function lsvmin ( p, l, x, y )

!***********************************************************************
!
!! LSVMIN estimates the smallest singular value of a lower triangular matrix.
!
!  Discussion:
!
!    This function returns a good over-estimate of the smallest
!    singular value of the packed lower triangular matrix L.
!
!    The matrix L is a lower triangular matrix, stored compactly by rows.
!
!    The algorithm is based on Cline, Moler, Stewart and Wilkinson,
!    with the additional provision that LSVMIN = 0 is returned if the
!    smallest diagonal element of L in magnitude is not more than the unit
!    roundoff times the largest.
!
!    The algorithm uses a random number generator proposed by Smith,
!    which passes the spectral test with flying colors; see Hoaglin and
!    Knuth.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    Alan Cline, Cleve Moler, Pete Stewart, James Wilkinson,
!    An Estimate of the Condition Number of a Matrix,
!    Report TM-310,
!    Applied Math Division,
!    Argonne National Laboratory, 1977.
!
!    DC Hoaglin,
!    Theoretical Properties of Congruential Random-Number Generators,
!    An Empirical View,
!    Memorandum NS-340,
!    Department of Statistics,
!    Harvard University, 1976.
!
!    Donald Knuth,
!    The Art of Computer Programming,
!    Volume 2, Seminumerical Algorithms,
!    Addison Wesley, 1969.
!
!    CS Smith,
!    Multiplicative Pseudo-Random Number Generators with Prime Modulus,
!    Journal of the Association for Computing Machinery,
!    Volume 19, pages 586-593, 1971.
!
!  Parameters:
!
!    Input, integer P, the order of L.
!
!    Input, real L((P*(P+1))/2), the elements of the lower triangular
!    matrix in row order, that is, L(1,1), L(2,1), L(2,2), L(3,1), L(3,2),
!    L(3,3), and so on.
!
!    Output, real X(P).  If LSVMIN returns a positive value, then X
!    is a normalized approximate left singular vector corresponding to
!    the smallest singular value.  This approximation may be very
!    crude.  If LSVMIN returns zero, then some components of X are zero
!    and the rest retain their input values.
!
!    Output, real Y(P).  If LSVMIN returns a positive value, then
!    Y = inverse ( L ) * X is an unnormalized approximate right singular
!    vector corresponding to the smallest singular value.  This
!    approximation may be crude.  If LSVMIN returns zero, then Y
!    retains its input value.  The caller may pass the same vector for X
!    and Y, in which case Y overwrites X, for nonzero LSVMIN returns.
!
  implicit none

  integer p

  real b
  integer i
  integer ii
  integer, save :: ix = 2
  integer j
  integer j0
  integer ji
  integer jj
  real l((p*(p+1))/2)
  real lsvmin
  real psj
  real sminus
  real splus
  real t
  real v2norm
  real x(p)
  real xminus
  real xplus
  real y(p)
!
!  First check whether to return LSVMIN = 0 and initialize X.
!
  ii = 0

  do i = 1, p

    x(i) = 0.0E+00
    ii = ii + i

    if ( l(ii) == 0.0E+00 ) then
      lsvmin = 0.0E+00
      return
    end if

  end do

  if ( mod ( ix, 9973 ) == 0 ) then
    ix = 2
  end if
!
!  Solve L' * X = B, where the components of B have randomly
!  chosen magnitudes in ( 0.5, 1 ) with signs chosen to make X large.
!
  do j = p, 1, -1
!
!  Determine X(J) in this iteration.  Note for I = 1, 2,..., J
!  that X(I) holds the current partial sum for row I.
!
    ix = mod ( 3432 * ix, 9973 )
    b = 0.5E+00 * ( 1.0E+00 + real ( ix ) / 9973.0E+00 )
    xplus = ( b - x(j) )
    xminus = ( -b - x(j) )
    splus = abs ( xplus )
    sminus = abs ( xminus )
    j0 = ( j * ( j - 1 ) ) / 2
    jj = j0 + j
    xplus = xplus / l(jj)
    xminus = xminus / l(jj)

    do i = 1, j - 1
      ji = j0 + i
      splus = splus + abs ( x(i) + l(ji) * xplus )
      sminus = sminus + abs ( x(i) + l(ji) * xminus )
    end do

    if ( splus < sminus ) then
      xplus = xminus
    end if

    x(j) = xplus
!
!  Update partial sums.
!
    do i = 1, j - 1
      ji = j0 + i
      x(i) = x(i) + l(ji) * xplus
    end do

  end do
!
!  Normalize X.
!
  t = 1.0E+00 / v2norm ( p, x )
  x(1:p) = t * x(1:p)
!
!  Solve L * Y = X.
!  return SVMIN = 1 / twonorm ( Y ).
!
  do j = 1, p

    psj = 0.0E+00
    j0 = ( j * ( j - 1 ) ) / 2

    do i = 1, j - 1
      ji = j0 + i
      psj = psj + l(ji) * y(i)
    end do

    jj = j0 + j
    y(j) = ( x(j) - psj ) / l(jj)

  end do

 lsvmin = 1.0E+00 / v2norm ( p, y )

  return
end
subroutine ltsqar ( n, a, l )

!***********************************************************************
!
!! LTSQAR sets A to the lower triangle of L' * L.
!
!  Discussion:
!
!    L is an N by N lower triangular matrix, stored by rows.
!
!    A is also stored by rows, and may share storage with L.
!
!  Modified:
!
!    03 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer N, the order of L and A.
!
!    Output, real A((N*(N+1))/2), the lower triangle of L' * L,
!    stored by rows.
!
!    Input, real L((N*(N+1))/2), the lower triangular matrix,
!    stored by rows.
!
  implicit none

  integer n

  real a((n*(n+1))/2)
  integer i
  integer i1
  integer ii
  integer j
  integer k
  real l((n*(n+1))/2)
  integer m

  ii = 0

  do i = 1, n

    i1 = ii + 1
    ii = ii + i
    m = 1

    do j = i1, ii - 1
      do k = i1, j
        a(m) = a(m) + l(j) * l(k)
        m = m + 1
      end do
    end do

    do j = i1, ii
      a(j) = l(ii) * l(j)
    end do

  end do

  return
end
subroutine madj ( n, p, x, nf, j, uiparm, urparm, ufparm )

!*****************************************************************************80
!
!! MADJ is a sample jacobian routine.
!
  implicit none

  integer n
  integer p

  real j(n,p)
  integer nf
  integer uiparm(*)
  external ufparm
  real urparm(*)
  real x(p)

  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
subroutine madr ( n, p, x, nf, r, uiparm, urparm, ufparm )

!*****************************************************************************80
!
!! MADR is a sample residual routine.
!
  implicit none

  integer n
  integer p

  integer nf
  real r(n)
  external ufparm
  integer uiparm(*)
  real urparm(*)
  real x(p)

  r(1) = x(1)**2 + x(2)**2 + x(1)*x(2)
  r(2) = sin(x(1))
  r(3) = cos(x(2))

  return
end
subroutine maflt ( y, n, k, yf, nyf )

!*****************************************************************************80
!
!! MAFLT performs a moving average filtering operation.
!
!  Discussion:
!
!    this subroutine performs a simple moving average filtering
!    operation on an input series y, returning the filtered series
!    in yf.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     real hma
!        the value of each of the simple moving average linear filter
!        coefficients.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer k
!        the number of filter terms.
!     character*1 lk(8), ln(8), lone(8)
!        the arrays containing the names of the variables k and n.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
  implicit none

  integer &
     k,n,nyf
!
!  array arguments
  real &
     y(*),yf(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     hma
  logical &
     err01,err02,err03,head
!
!  local arrays
  character &
     lk(8)*1,ln(8)*1,lone(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,eisii,eriodd,fltma
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  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', ' ', ' ', ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  call eisii(nmsub, lk, k, 1, n, 1, head, err02, lone, ln)

  call eriodd(nmsub, lk, k, 1, head, err03)

  if (err01 .or. err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  compute the simple moving average coefficients
!
  hma = real ( k )
  hma = 1.0e0 / hma

  call fltma ( y, n, k, hma, yf, nyf )

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call maflt (y, n, k, yf, nyf)')
end
subroutine matprf ( x, y, nc, mode, code, length, mask, lmask )

!*****************************************************************************80
!
!! MATPRF prints a square matrix stored in symmetric form.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer code
!        if 1 -single printed, x only (y is dummy arg)
!           2 -double printed line, both x and y
!     integer i
!        row number
!     integer ii
!        the index of the (i,i)th element of the vcv matrix
!     integer ik
!        the index of the (i,k)th element of the vcv matrix
!     integer i0
!        the index of the ((i,i)-1)th element of the vcv matrix
!     integer imask
!        index in mask for labelling of the row dimension.
!     integer indw(10)
!        a work vector for the indices to be printed for the
!        matrix.
!     integer j
!        first column in the set to be printed
!     integer jmask
!        index in mask for labelling of the column dimension.
!     integer k
!        column number in the possible set of nf
!     integer ki
!        the index of the (k,i)th element of the vcv matrix
!     integer kk
!        the index of the (k,k)th element of the vcv matrix
!     integer km
!        last column in the set
!        limited to values of j-1 plus a number between 1 and
!        nf (inclusive)
!     integer kmax
!        index in indw of the largest index to be printed for
!        matrix.
!     integer kn
!        last column to print when printing lower triangle
!     integer l
!        first row to print for this set
!     integer lmask
!        length of mask.
!     integer length
!        length of x and y
!     integer mask(lmask)
!        mask vector for vcv.  the index of the ith element of
!        mask equal to zero is the label in the output of vcv
!        in of the ith row and ith column.
!     integer mode
!        if 0, lower triangular part printed
!           1, lower triangular part is printed with
!              square roots of the diagonal
!           2, lower triangle printed as correlation matrix
!              with square roots on the diagonal
!           3, full matrix printed
!           4, full matrix printed with correlation matrix
!              printed below the diagonal
!     integer nc
!        row and column dimension of x
!     integer nf
!        the number of columns that can be printed, given
!        the width iwidth of the output device.
!     integer nline
!        the number of values to be printed each line.
!     real sqxii, sqyii
!        the square root of the (i,i)th element of x and y.
!     real x(length)
!        input symmetric array stored row wise
!     real xline(10)
!        the current values being printed from array x.
!     real y(length)
!        array to be printed on the second level if code=2
!     real yline(10)
!        the current values being printed from array y.
!
  implicit none

  integer &
     code,length,lmask,mode,nc
!
!  array arguments
  real &
     x(length),y(length)
  integer &
     mask(lmask)
!
!
  real &
     sqxii,sqyii
  integer &
     i,i0,ii,ik,imask,j,jmask,k,ki,kk,km,kmax,kn,l,nf, &
     nline
!
!  local arrays
  real &
     xline(10),yline(10)
  integer &
     indw(10)
!
!  external functions
  integer &
     inperl
  external inperl

  nf = inperl( )

  l = 1
  jmask = 0
!
!  select initial column to print this pass of the report
!
  do j=1,nc,nf

     kn = min(nc,j+nf-1)
     kmax = min(nc-j+1,nf)
!
!  generate vector of column head labels
!
     do k=1,kmax

       do

         if ( jmask >= lmask ) then
           write ( *,1040)
           return
         end if

         jmask = jmask + 1

         if ( mask(jmask) == 0 ) then
           exit
         end if

       end do

       indw(k) = jmask

     end do
!
!  print vector of column head labels
!
     write ( *,1000) (indw(k),k=1,kmax)
     write ( *,1030)
     if (mode <= 2) l = indw(1)
!
!  print all rows in column range for this pass
!
     imask = l - 1

     do i=l,nc

        km = kn
        if (mode <= 2) km = j + min(i-l,nf-1)
        nline = 0
        i0 = i*(i-1)/2
        ii = i0 + i
        sqxii = sqrt(x(ii))

        if (code == 2) then
           sqyii = sqrt(y(ii))
        else
           sqyii = 1.0e0
        end if

        do k = j, km

           nline = nline + 1

           if ( k <= i ) then
             ik = i0 + k
             xline(nline) = x(ik)
             if (code == 2) yline(nline) = y(ik)
           else
             ki = k*(k-1)/2 + i
             xline(nline) = x(ki)
             if (code == 2) yline(nline) = y(ki)
           end if

           if (((mode == 1) .or. (mode == 2)) .and. (i == k)) then
             xline(nline) = sqxii
             if (code == 2) yline(nline) = sqxii
           end if

           if (((mode /= 2) .and. (mode /= 4)) .or. (k >= i)) then
             cycle
           end if

           kk = k*(k-1)/2 + k
           xline(nline) = xline(nline)/(sqxii*sqrt(x(kk)))

           if (code == 2) then
              yline(nline) = yline(nline)/(sqyii*sqrt(y(kk)))
           end if

         end do

         do

           if (imask >= lmask) then
             write ( *, 1040 )
             return
           end if

           imask = imask + 1

           if ( mask(imask) == 0 ) then
             exit
           end if

        end do

        write ( *,1010) imask, (xline(k),k=1,nline)

        if (code == 2) then
          write ( *,1020) (yline(k),k=1,nline)
          write ( *,1030)
        end if

    end do

  end do

  return

 1000 format (/' column ', 7(i9, 8x))
 1010 format (' ', i6, 1x, 7(3x, g14.7))
 1020 format (' ', 5x, 7(3x, g14.7))
 1030 format (' ')
 1040 format (/' error in starpac.  matprf tries to access more', &
     ' elements than exist in mask.')
end
subroutine matprt (x, y, nc, mode, code, irdim)

!*****************************************************************************80
!
!! MATPRT is a matrix printing routine.
!
!  Discussion:
!
!    this subroutine takes a square matrix and prints either its
!    lower triangular part or the full matrix with or without double
!    printing.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer code
!                  if 1 -single printed line, x only (y is dummy arg)
!                     2 -double printed line, both x and y
!     integer i
!                  row number
!     integer irdim
!                  row index of x
!     integer iwidth
!                  the width of the output device.
!     integer j
!                  first column in the set to be printed
!     integer k
!                  column number in the possible set of nf
!     integer km
!                  last column in the set
!                   limited to values of j-1 plus a number between 1 and
!                   nf (inclusive)
!     integer kn
!                  last column to print when printing lower triangle
!     integer l
!                  first row to print for this set
!     integer mode
!                  if 0, lower triangular part printed
!                     1, full matrix printed
!                     2, lower triangular part is printed with
!                        square roots of the diagonal
!     integer nc
!                  row and column dimension of x
!     integer nf
!                  the number of columns that can be printed, given
!                  the width iwidth of the output device.
!     real temp
!                  a temporary location
!     real x(irdim,nc)
!                  nc by nc input matrix
!     real y(irdim,nc)
!                  matrix to be printed on the second level if code=2
!
  implicit none

  integer &
     code,irdim,mode,nc
!
!  array arguments
  real &
     x(irdim,nc),y(irdim,nc)
!
!
  real &
     temp
  integer &
     i,iwidth,j,k,km,kn,l,nf

  iwidth = 132
  nf = min(7, (iwidth - 7)/17)
  l = 1
  do j=1,nc, nf
     kn = min(nc, j+nf-1)
     write ( *,1000) (k,k=j,kn)
     write ( *,1030)
     if ((mode == 00) .or. (mode == 2)) l = j
     do i=l,nc
        temp = x(i,i)
        km = kn
        if ((mode == 0) .or. (mode == 2)) &
           km = j + min(i-l, nf-1)
        if ((mode == 2) .and. ((i >= j) .and. (i <= km))) &
           x(i,i) = sqrt(x(i,i))
        write ( *,1010) i, (x(i,k),k=j,km)

        if (code == 2) then
          write ( *,1020) (y(i,k),k=j,km)
          write ( *,1030)
        end if

        x(i,i) = temp

     end do
  end do

  return

 1000 format (/4x, 'column ', 7(i9, 8x))
 1010 format (4x, i6, 1x, 7(3x, g14.8))
 1020 format (9x, 7(3x, g14.8))
 1030 format (4x)
end
subroutine mdflt ( per, nf, nk, kmd, perf, ldstak )

!*****************************************************************************80
!
!! MDFLT is a user routine for a modified Daniels filter of symmetric series.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer kmd(nk)
!        the array of filter lengths.
!     character*1 lkmd(8), llds(8), lnk(8), lnf(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer nall0
!        the number of outstanding stack allocations
!     integer nf
!        the number of points in the series to be filtered.
!     integer nk
!        the number of filters to be applied.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     real per(nf)
!        the input series to be filtered.
!     real perf(nf)
!        the filtered series.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real sym
!        an indicator variable used to designate whether the series
!        is symmetric (sym = 1.0e0) or not (sym = -1.0e0).
!     integer work
!        the starting location in the work area for the work vector.
!
  implicit none

  integer &
     ldstak,nf,nk
!
!  array arguments
  real &
     per(*),perf(*)
  integer &
     kmd(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     sym
  integer &
     l,ldsmin,nall0,work
  logical &
     err01,err02,err03,head
!
!  local arrays
  real &
     rstak(12)
  character &
     lkmd(8)*1,llds(8)*1,lnf(8)*1,lnk(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external eisge,eiveo,fltmd,ldscmp,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, lnf, nf, 17, 1, head, err01, lnf)

  call eisge(nmsub, lnk, nk, 1, 1, head, err02, lnk)

  if (.not.err02) call eiveo(nmsub, lkmd, kmd, nk, .true., head)

  if (err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call ldscmp(1, 0, 0, 0, 0, 0, 's', nf, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds)

  if ( err02 .or. err03 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set the size of the work area
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)
!
!  subdivide the work area
!
  work = stkget(nf, 3)
!
!  designate the series is symmetric
!
  sym = 1.0e0

  perf(1:nf) = per(1:nf)

  do l = 1, nk
     call fltmd(perf, rstak(work), nf, kmd(l), sym)
  end do

  call stkclr(nall0)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call mdflt (per, nf, nk, kmd, perf, ldstak)')
end
subroutine mdl1 ( par, npar, xm, n, m, ixm, pv )

!*****************************************************************************80
!
!! MDL1 is the model function for an NLS exerciser.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real par(npar)
!        model parameters
!     integer ixm
!        actual first dimension of xm
!     integer m
!        number of variables
!     integer n
!        number of observations
!     integer npar
!        number of parameters
!     real pv(n)
!        predicted values
!     real xm(ixm,m)
!        independent variables
!
  implicit none

  integer &
     ixm,m,n,npar
!
!  array arguments
  real &
     par(npar),pv(n),xm(ixm,m)

  pv(1:n) = par(1) * xm(1:n,1)**par(2)

  return
end
subroutine mdl2 ( par, npar, xm, n, m, ixm, pv )

!*****************************************************************************80
!
!! MDL2 is a model function for an NLS exerciser.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        row index
!     integer ixm
!        actual first dimension of xm
!     integer m
!        number of variables
!     integer n
!        number of observations
!     integer npar
!        number of parameters
!     real par(npar)
!        model parameters
!     real pv(n)
!        predicted values
!     real xm(ixm,m)
!        independent variables
!
  implicit none

  integer ixm
  integer m
  integer n
  integer npar

  real par(npar)
  real pv(n)
  real xm(ixm,m)

  pv(1:n) = par(1) * xm(1:n,1) + par(2) * xm(1:n,2) + par(3) * xm(1:n,3)**3

  return
end
subroutine mdl3 ( par, npar, xm, n, m, ixm, pv )

!*****************************************************************************80
!
!! MDL3 is a model function for an NLS exerciser.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        row index
!     integer ixm
!        actual first dimension of xm
!     integer m
!        number of variables
!     integer n
!        number of observations
!     integer npar
!        number of parameters
!     real par(npar)
!        model parameters
!     real pv(n)
!        predicted values
!     real xm(ixm,m)
!        independent variables
!
  implicit none

  integer &
     ixm,m,n,npar
!
!  array arguments
  real &
     par(npar),pv(n),xm(ixm,m)

  pv(1:n) = par(1) * xm(1:n,1) &
          + par(2) * xm(1:n,2) &
          + par(3) * xm(1:n,3) &
          + par(4) * xm(1:n,4) &
          + par(5) * xm(1:n,5)

  return
end
subroutine mdl4 ( par, npar, xm, n, m, ixm, pv )

!*****************************************************************************80
!
!! MDL4 is a model routine for step size and derivative checking routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index variable.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations of data.
!     integer npar
!        the number of unknown coefficients in the model.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        coefficients are stored.
!     real pv(n)
!        the predicted values from the fit.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  integer &
     ixm,m,n,npar
!
!  array arguments
  real &
     par(npar),pv(n),xm(ixm,m)

  pv(1:n) = par(1) + par(3)*exp(-((xm(1:n,1)-par(2))**2)/par(4))

  return
end
subroutine mdlts1 ( par, npar, xm, n, m, ixm, rests )

!*****************************************************************************80
!
!! MDLTS1 is the user callable routine for estimating box-jenkins arima models.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer i
!        an index variable.
!     integer iflag
!        an indicator variable designating whether the back forecasts
!        were essentially zero (iflag=0) or not (iflag=1).
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ixm
!        the first dimension of matrix xm.
!     integer m
!        the number of independent variables.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     integer mspect
!        the starting location in the work space for
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfact
!        the number of factors in the model
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer nparma
!        the length of the vector parma
!     integer nrests
!        the maximum number of residuals to be computed.
!     real par(npar)
!        the current estimates of the parameters.
!     integer parar
!        the starting location in the work array for
!        the autoregressive parameters
!     integer pardf
!        the starting location in the work space for
!        the vector containing the difference filter parameters
!     integer parma
!        the starting location in the work array for
!        the moving average parameters
!     real pmu
!        the value of mu, i.e., the trend or mean.
!     real rests(nrests)
!        the residuals from the arima model.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer t
!        the starting location in the work array for
!        a temporary work vector.
!     integer temp
!        the starting location in the work array for
!        a temporary work vector
!     real xm(ixm,m)
!        the independent variable.
!
  implicit none

  integer &
     ixm,m,n,npar,nrests
!
!  array arguments
  real &
     par(npar),rests(nrests),xm(ixm,m)
!
!  scalars in common
  integer &
     iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, &
     parar,pardf,parma,t,temp
!
!  arrays in common
  double precision dstak(12)

  real &
     pmu
  integer &
     i,i1
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external subroutines
  external mdlts2
!
!  common blocks
  common /cstak/dstak
  common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, &
     nparma,mbo,mbol,t,temp,nrests,iflag
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!   compute residuals
!
  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)
!
!  Compute predicted values
!
  i1=nrests-n
  do i = 1,n
    i1=i1+1
    rests(i) = xm(i1,1)-rests(i1)
  end do

  return
end
subroutine mdlts2 ( par, rests, y, npar, n, nfac, mspect, pmu, &
    pardf, npardf, t, temp, parar, parma, mbo, n1, n2, iflag )

!*****************************************************************************80
!
!! MDLTS2 is the model routine for Pack's specification of box-jenkins models.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real fplpm
!        the floating point largest positive magnitude.
!     integer i
!        an index variable.
!     integer iflag
!        an indicator variable designating whether the back forecasts
!        were essentially zero (iflag=0) or not (iflag=1).
!     integer imod
!        an index variable.
!     integer ipar
!        an index variable.
!     integer ipq
!        an index variable.
!     integer istart
!        ***
!     integer j
!        an index variable.
!     integer k
!        an index variable.
!     integer l
!        an index variable.
!     integer maxord
!        the largest back order.
!     integer mbo
!        the maximum back order operator.
!     integer mbo1
!        the value mbo+1
!     integer mspect(nfac,4)
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfac
!        the number of factors in the model
!     integer np
!        the number of parameters in the expanded term.
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer nparma
!        the length of the vector parma
!     integer n1
!        the lower bound for rests.
!     integer n2
!        the upper bound for rests.
!     real par(npar)
!        the current estimates of the parameters.
!     real parar(mbo)
!        the autoregressive parameters
!     real pardf(npardf)
!        the vector containing the difference filter parameters.
!     logical parle1
!        a flag indicating whether all of the moving average parameters
!        are less than or equal to 1 (parle1 = .true.) or not
!        (parle1 = .false.)
!     real parma(mbo)
!        the moving average parameters
!     real pmu
!        the value of mu, i.e., the trend or mean.
!     real resmax
!        the largest possible residual which will still avoid overflow.
!     real rests(n1:n2)
!        the predicted value of the fit.
!     real t(2*mbo)
!        a temporary work vector.
!     real temp(mbo)
!        a temporary work vector
!     real wtest
!        the test value used to determine if the differenced series
!        back forecast is effectively zero or not.
!     real y(n)
!        the dependent variable.
!
  implicit none

  integer n
  integer n1
  integer n2
  integer nfac
  integer npar

  real fplpm
  integer iflag
  integer mbo
  integer mspect(nfac,4)
  integer npardf
  real par(npar)
  real parar(*)
  real pardf(*)
  logical parle1
  real parma(*)
  real pmu
  real resmax
  real rests(n1:n2)
  real t(*)
  real temp(*)
  real wtest
  real y(n)

  integer &
     i,imod,imod1,ipar,ipq,istart,j,k,l,maxord,mbo1,np,nparar, &
     nparma

  fplpm = huge ( fplpm )
!
!  DEBUG:
!    Is FPLPM way too huge?
!
  fplpm = 1.0E+30
!
!  Zero the parameter arrays parar and parma.
!
  t(1:mbo) = 0.0e0
  temp(1:mbo) = 0.0e0

  np = 0
  ipar = 0
  nparar = 0
  istart = 0
!
!  expand the model and store autoregressive parameters in parar
!  and moving average parameters in parma
!
  do ipq = 1, 3, 2

    do l=1,nfac

      if (mspect(l,ipq) /= 0) then

        maxord = mspect(l,ipq)*mspect(l,4)
        do k = mspect(l,4), maxord, mspect(l,4)
          ipar = ipar + 1
          temp(k) = temp(k) + par(ipar)
          do i = 1, np
            temp(k+i) = temp(k+i) - t(i)*par(ipar)
          end do
        end do

        np = np + maxord
        t(1:np) = temp(1:np)

      end if

    end do

      if (ipq /= 3) then
        ipar = ipar + 1
        pmu = par(ipar)
        nparar = np
        do k =1, nparar
           parar(k) = t(k)
           t(k) = 0.0e0
           temp(k) = 0.0e0
        end do
        np = 0
     end if

  end do

  nparma = np
  parle1 = .true.
  do k =1, nparma
     parma(k) = t(k)
     if (abs(parma(k)) > 1.0e0) parle1 = .false.
  end do
!
!  compute fitted values and residuals for model.
!
!  compute w, the differenced series minus its mean, and store in
!  rests(npardf+1) to rests(n2)
!
  do i = npardf+1, n2, 1
     rests(i) = y(i) - pmu
     do j = 1,npardf
        rests(i) = rests(i) - pardf(j)*y(i-j)
     end do
  end do

  wtest = abs(rests(npardf+1))*0.01
!
!  back forecast the error, e, for i = n-nparar to npardf+1, and
!  the differenced series for i = npardf to n1
!
  mbo1 = mbo+1
  iflag = 0

  do i = n2-nparar,npardf+1,-1

     imod = mod(i+1-n1,mbo1) + 1

     t(imod) = rests(i)
     do j = 1,nparar
        t(imod) = t(imod) - parar(j)*rests(i+j)
     end do

     do j = 1,nparma
        if ((i+j > npardf) .and. (i+j <= n)) &
           t(imod) = t(imod) + parma(j)*t(mod(i+j+1-n1,mbo1)+1)
     end do

  end do

  do i = npardf,n1,-1

     imod = mod(i+1-n1,mbo1) + 1
     rests(i) = 0.0e0
     do j = 1,nparar
        rests(i) = rests(i) + parar(j) * rests(i+j)
     end do

     do j = 1,nparma
        if ((i+j > npardf) .and. (i+j <= n)) &
           rests(i) = rests(i) - &
                      parma(j)*t(mod(i+j+1-n1,mbo1)+1)
     end do

     istart = i
     if ((istart <= 1) .and. (abs(rests(i)) <= wtest)) go to 180

  end do

  iflag = 1
!
!  compute residuals and store values in rests
!
  180 continue

  do i = istart,n2,1

    imod = mod(i+1-n1,mbo1) + 1
    t(imod) = rests(i)

    do j = 1,nparar
      if (i-j >= istart) then
        t(imod) = t(imod) - parar(j)*rests(i-j)
      end if
    end do
!
!  Compute residuals where there is no chance of overflow.
!
     if ( parle1 ) then
       do j = 1, nparma
         if (i-j >= istart) then
           t(imod) = t(imod) + parma(j)*t(mod(i-j+1-n1,mbo1)+1)
         end if
       end do
!
!  Compute residuals where there is a chance of overflow.
!
     else

       do j = 1, nparma

         if ( istart <= i - j ) then

           imod1 = mod(i-j+1-n1,mbo1)+1

           if ( parma(j) /= 0.0e0 .and. t(imod1) /= 0.0e0 ) then

             if ( log ( abs ( parma(j) ) ) &
                + log ( abs ( t(imod1) ) ) < log(fplpm) .and. &
                sign ( 1.0e0, t(imod) ) /= &
                sign ( 1.0e0, parma(j) * t(imod1) ) ) then

               t(imod) = t(imod) + parma(j) * t(imod1)

             else if ( log ( abs ( parma(j) ) ) &
                     + log ( abs ( t(imod1) ) ) < &
                       log ( fplpm - abs ( t(imod) ) ) ) then

               t(imod) = t(imod) + parma(j) * t(imod1)

             else

               go to 300

             end if

           end if

         end if

      end do

    end if

    if (i-mbo >= istart) then
      rests(i-mbo) = t(mod(i-mbo+1-n1,mbo1)+1)
    end if

  end do

  do i = n-mbo+1,n
    rests(i) = t(mod(i-mbo+2-n1,mbo1)+1)
  end do

  rests(n1:istart-1) = 0.0e0

  return
!
!  Set residuals to largest possible value.
!
  300 continue

  resmax = sqrt ( fplpm / real ( n2 - n1 + 1 ) )
  rests(n1:n2) = resmax

  return
end
subroutine mdlts3 ( par, npar, xm, n, m, ixm, rests )

!*****************************************************************************80
!
!! MDLTS3 is the user callable routine for estimating Box-Jenkins ARIMA models.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer iflag
!        an indicator variable designating whether the back forecasts
!        were essentially zero (iflag=0) or not (iflag=1).
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ixm
!        the first dimension of matrix xm.
!     integer m
!        the number of independent variables.
!     integer mbo
!        the maximum back order operator.
!     integer mbol
!        the maximum back order on the left
!     integer mspect
!        the starting location in the work space for
!        the array containing the values of p, d, q, and s for each fact
!     integer n
!        the number of observations.
!     integer nfact
!        the number of factors in the model
!     integer npar
!        the number of parameters in the model.
!     integer nparar
!        the number of autoregressive parameters
!     integer npardf
!        the order of the expanded difference filter.
!     integer nparma
!        the length of the vector parma
!     integer nrests
!        the maximum number of residuals to be computed.
!     real par(npar)
!        the current estimates of the parameters.
!     integer parar
!        the starting location in the work array for
!        the autoregressive parameters
!     integer pardf
!        the starting location in the work space for
!        the vector containing the difference filter parameters
!     integer parma
!        the starting location in the work array for
!        the moving average parameters
!     real pmu
!        the value of mu, i.e., the trend or mean.
!     real rests(nrests)
!        the residuals from the arima model.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer t
!        the starting location in the work array for
!        a temporary work vector.
!     integer temp
!        the starting location in the work array for
!        a temporary work vector
!     real xm(ixm,m)
!        the independent variable.
!
  implicit none

  integer &
     ixm,m,n,npar
  integer nrests
!
!  array arguments
  real &
     par(npar),rests(nrests),xm(ixm,m)
!
!  scalars in common
  integer &
     iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, &
     parar,pardf,parma,t,temp
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     pmu
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external subroutines
  external mdlts2

  common /cstak/dstak

  common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, &
     nparma,mbo,mbol,t,temp,nrests,iflag
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!  compute residuals
!
  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 )

  return
end
subroutine mgs ( a, b, n, np, x, c, d, r, ir, ia, ier )

!*****************************************************************************80
!
!! MGS solves a linear system using modified Gram-Schmidt algorithm.
!
!  Discussion:
!
!    this routine computes the solution  x  to the linear system of
!    equations  ax=b, using the method of modified gram-schmidt.
!    the matrix a is decomposed into three matrices
!      q  an orthogonal matrix
!      d  a diagonal matrix and
!      r  an upper triangular matrix
!    the solution vector x is the vector which solves the system
!    of equations  rx = c
!    x, a, and b are not preserved on output
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real a(ia,np)
!           the coefficients matrix (not preserved on output)
!     real b(n)
!           the constant column matrix of the system (not preserved
!           on output)
!     real c(np)
!           the matrix c described above
!     real d(np)
!           the diagonal elements of the matrix d described above
!     integer ia
!           the row dimension of a.
!     integer ir
!           the row dimension of r.
!     integer n
!           the number of observations
!     integer np
!           the number of parameters
!     real r(ir,np)
!           the upper elements of the matrix r described above
!     real x(np)
!           the solution matrix
!
  implicit none

  integer &
     ia,ier,ir,n,np
!
!  array arguments
  real &
     a(ia,np),b(n),c(np),d(np),r(ir,np),x(np)
!
!
  real &
     sm1,sm2
  integer &
     i,j,jj,k,npjjmj

  ier = 0
  sm1 = 0.0e0
  sm2 = 0.0e0
  do i=1,n
     sm1 = a(i,1)*a(i,1) + sm1
     sm2 = a(i,1)*b(i) + sm2
  end do

  if (sm1 == 0.0e0) then
    ier = 1
    return
  end if

  d(1) = sm1
  c(1) = sm2/sm1

  do k=2,np

     do j=k,np
        sm1 = 0.0e0
        do i=1,n
           sm1 = a(i,k-1)*a(i,j) + sm1
        end do

        r(k-1,j) = sm1/d(k-1)
        a(1:n,j) = a(1:n,j) - a(1:n,k-1) * r(k-1,j)
     end do

     sm1 = 0.0e0
     sm2 = 0.0e0
     do 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
     end do

     if (sm1 == 0.0e0) then
       ier = 1
       return
     end if

     d(k) = sm1
     c(k) = sm2/sm1

  end do
!
!  complete backsolve
!
  x(np) = c(np)

  if (np == 1) then
    return
  end if

  do i=2,np
     k = np + 1 - i
     jj = k + 1
     sm1 = 0.0e0
     do j=jj,np
        npjjmj = np + jj - j
        sm1 = r(k,npjjmj)*x(npjjmj) + sm1
     end do
     x(k) = c(k) - sm1
  end do

  return
end
subroutine modsum ( nfac, mspect )

!*****************************************************************************80
!
!! MODSUM prints the model summary for the ARIMA routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer nfac
!        the number of factors in the model
!     integer mspect(nfac,4)
!        the array containing the values of p, d, q, and s for each fact
!
  implicit none

  integer &
     nfac
!
!  array arguments
  integer &
     mspect(nfac,4)

  integer &
     i,j
!
!  print model specification
!
  write ( *, 1002) (i, (mspect(i,j),j=1,4), i=1,nfac)

  return

 1002 format(// &
     '    model specification'// &
     '       factor          (p     d     q)    s'// &
     (7x, i6, 6x, 4i6))
end
subroutine mppc ( ym, x, n, m, iym, ilog, isize, nout, ylb, yub, xlb, xub )

!*****************************************************************************80
!
!! MPPC produces a simple page plot with multiple Y-axis values.
!
!  Discussion:
!
!    This is the long call version.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        vector of observations for the y coordinates
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
  implicit none

  real &
     xlb,xub,ylb,yub
  integer &
     ilog,isize,iym,m,n,nout
!
!  array arguments
  real &
     x(*),ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xmiss
  integer ischck,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'p',       'p',       'c',       ' ',       ' '/

  xmiss = 1.0e0
  multi = .true.
  ischck = 2
  miss = .false.
  lisym = 1

  call ppcnt (ym, ym, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine mpp ( ym, x, n, m, iym )

!*****************************************************************************80
!
!! MPP produces a simple page plot with multiple Y-axis values.
!
!  Discussion:
!
!    This is the short call version.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        vector of observations for the y coordinates
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
  implicit none

  integer &
     iym,m,n
!
!  array arguments
  real &
     x(*),ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,ischck,isize,lisym,nout
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'p',       'p',       ' ',       ' ',       ' '/

  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

  call ppcnt (ym, ym, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
  end if

  return
end
subroutine mppl ( ym, x, n, m, iym, ilog )

!*****************************************************************************80
!
!! MPPL produces a simple page plot with multiple Y-axis values, and log option.
!
!  Discussion:
!
!    this is the user callable routine which produces a simple page
!    plot with multiple y-axis values (log option).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        vector of observations for the y coordinates
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
  implicit none

  integer &
     ilog,iym,m,n
!
!  array arguments
  real &
     x(*),ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xmiss,xub,ylb,yub
  integer ischck,isize,lisym,nout
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!  set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'p',       'p',       'l',       ' ',       ' '/

  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

  call ppcnt (ym, ym, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call mppl (ym, x, n, m, iym, ilog)')
end
subroutine mppmc ( ym, ymmiss, x, xmiss, n, m, iym, ilog, isize, &
     nout, ylb, yub, xlb, xub )

!*****************************************************************************80
!
!! MPPMC: produce a page plot with multiply Y-axis values, and missing data.
!
!  Discussion:
!
!    This is the user callable routine which produces a simple page
!    plot with multiple y-axis values and with missing
!    observations (long call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,m)
!        vector of observations for the y coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
  implicit none

  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,isize,iym,m,n,nout
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer ischck,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'p',       'p',       'm',       'c',       ' '/

  multi = .true.
  ischck = 2
  miss = .true.
  lisym = 1

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' 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
subroutine mppm ( ym, ymmiss, x, xmiss, n, m, iym )

!*****************************************************************************80
!
!! MPPM: produce a page plot with multiple Y-axis values and missing data.
!
!  Discussion:
!
!    this is the user callable routine which produces a simple page
!    plot with multiple y-axis values and with missing
!    observations (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        vector of observations for the y coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
  implicit none

  real &
     xmiss
  integer &
     iym,m,n
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xub,ylb,yub
  integer &
     ilog,ischck,isize,lisym,nout
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'p',       'p',       'm',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call mppm (ym, ymmiss, x, xmiss, n, m, iym)')
end
subroutine mppml ( ym, ymmiss, x, xmiss, n, m, iym, ilog )

!*****************************************************************************80
!
!! MPPML: plot multiple Y-axis values with missing data, log option.
!
!  Discussion:
!
!    This is the user callable routine which produces a simple page
!    plot with multiple y-axis values and with missing
!    observations (log option).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xmiss
  integer &
     ilog,iym,m,n
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xub,ylb,yub
  integer ischck,isize,lisym,nout
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        vector of observations for the y coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'p',       'p',       'm',       'l',       ' '/

  multi = .true.
  ylb = 0.0e0
  yub = 0.0e0
  xlb = 0.0e0
  xub = 0.0e0
  ischck = 2
  isize = -1
  nout = 0
  miss = .true.
  lisym = 1

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call mppml (ym, ymmiss, x, xmiss, n, m, iym, ilog)')
end
subroutine msgx ( ier )

!*****************************************************************************80
!
!! MSGX prints the returned and expected values for the error flag IERR.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ier
!
!  scalars in common
  integer &
     ierr
!
!  common blocks
  common /errchk/ierr
!
!     varible definitions (alphabetically)
!
!     integer ier
!        expected value of error flag ierr
!     integer ierr
!        returned error flag found in the common errchk
!
  write ( *,1000) ier, ierr

  if (ier /= ierr) write ( *,1010)

  return

 1000 format(/' expected value for ierr is ', i1/' returned value', &
     ' for ierr is', i2)
 1010 format(' possible error, unexpected value for error flag')
end
subroutine multbp ( t, lt, c, lc, temp, ltemp, mbo )

!*****************************************************************************80
!
!! MULTBP multiplies two difference factors from Box-Jenkins time series model.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real c(mbo)
!        the second factor on input and the expanded factor on output.
!     integer lc
!        the largest order of the second factor on input, and
!        the largest order of the expanded factor on output.
!     integer lt
!        the largest order of the first factor.
!     integer ltemp
!        the length of the vector temp.
!     integer mbo
!        the maximum back order operator.
!     real t(2*mbo)
!        a temporary work vector.
!     real temp(mbo)
!        a temporary work vector
!
  implicit none

  integer mbo

  real c(mbo)
  integer i
  integer j
  integer ji
  integer lc
  integer lt
  integer ltemp
  real t(2*mbo)
  real temp(mbo)

  temp(1:lc) = c(1:lc)
  temp(lc+1:ltemp) = 0.0e0

  do j=1,lt
     temp(j) = temp(j) + t(j)
     do i=1,lc
        ji = j + i
        temp(ji) = temp(ji) - c(i)*t(j)
     end do
  end do

  c(1:ltemp) = temp(1:ltemp)
  lc = ltemp

  return
end
function mvchk ( x, xmiss )

!*****************************************************************************80
!
!! MVCHK checks whether the input value equals the flag value for missing data.
!
!  Discussion:
!
!    This routine checks whether x = xmiss (mvchk = true) or not
!    (mvchk = false) in a manner which will prevent very large or
!    very small missing value codes from causing an overflow.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real x
!        the value to be checked.
!     real xmiss
!        the user supplied code which is used to determine whether or
!        not an observation is missing.  if x = xmiss,
!        the value is assumed missing, otherwise it is not.
!
  implicit none

  logical mvchk
  real x
  real xmiss

  if ((x > 0.0e0 .and. xmiss < 0.0e0) .or. &
      (x < 0.0e0 .and. xmiss > 0.0e0)) then
    mvchk = .false.
  else if (abs(x) == abs(xmiss)) then
    mvchk = .true.
  else
    mvchk = .false.
  end if

  return
end
subroutine mvpc ( ym, n, m, iym, ns, ilog, isize, ylb, yub, xlb, xinc )

!*****************************************************************************80
!
!! MVPC produces a vertical plot with multiple Y-axis values.
!
!  Discussion:
!
!    This is the user callable routine which produces a vertical
!    plot with multiple y-axis values (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xinc,xlb,ylb,yub
  integer &
     ilog,isize,iym,m,n,ns
!
!  array arguments
  real &
     ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     ibar,irlin,ischck,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(iym,m)
!        multivariate observations for the y coordinates
!     real yub
!        upper bound for y-axis.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'v',       'p',       'c',       ' ',       ' '/

  multi = .true.
  irlin = -1
  ibar = -1
  ischck = 2
  miss = .false.
  lisym = 1

  call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if
  return

 1000 format (/' the correct form of the call statement is'// &
   '       call mvpc (ym, n, m, iym, ns, ilog,'/ &
   '      +           isize, ylb, yub, xlb, xinc)')
end
subroutine mvp ( ym, n, m, iym, ns )

!*****************************************************************************80
!
!! MVP produces a vertical plot with multiple Y-axis values.
!
!  Discussion:
!
!    This is the user callable routine which produces a vertical
!    plot with multiple y-axis values (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iym,m,n,ns
!
!  array arguments
  real &
     ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,ischck,isize,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(iym,m)
!        multivariate observations for the y coordinates
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'v',       'p',       ' ',       ' ',       ' '/

  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

  call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call mvp (ym, n, m, iym, ns)')
end
subroutine mvpl ( ym, n, m, iym, ns, ilog )

!*****************************************************************************80
!
!! MVPL produces a vertical plot with multiple y-axis values (log plot option).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ilog,iym,m,n,ns
!
!  array arguments
  real &
     ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,irlin,ischck,isize,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(iym,m)
!        multivariate observations for the y coordinates
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'v',       'p',       'l',       ' ',       ' '/

  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

  call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' 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 )

!*****************************************************************************80
!
!! MVPMC: vertical plot with missing data, multiple y-axis values (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xinc,xlb,ylb,yub
  integer &
     ilog,isize,iym,m,n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     ibar,irlin,ischck,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(iym,m)
!        multivariate observations for the y coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'v',       'p',       'm',       'c',       ' '/

  multi = .true.
  irlin = -1
  ibar = -1
  ischck = 2
  miss = .true.
  lisym = 1

  call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if
  return

 1000 format (/' 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 )

!*****************************************************************************80
!
!! MVPM: vertical plot with missing data, multiple y-axis values (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iym,m,n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,ischck,isize,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(iym,m)
!        multivariate observations for the y coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'v',       'p',       'm',       ' ',       ' '/

  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

  call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return
 1000 format (/' the correct form of the call statement is'// &
    '       call mvpm (ym, ymmiss, n, m, iym, ns)')
end
subroutine mvpml ( ym, ymmiss, n, m, iym, ns, ilog )

!*****************************************************************************80
!
!! MVPML: vertical plot with missing data, multiple y-axis values (log option).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ilog,iym,m,n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,irlin,ischck,isize,lisym
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(iym,m)
!        multivariate observations for the y coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'm',       'v',       'p',       'm',       'l',       ' '/

  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

  call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym )

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if
  return

 1000 format (/' the correct form of the call statement is'// &
    '       call mvpml (ym, ymmiss, n, m, iym, ns, ilog)')
end
function nchose ( n, k )

!*****************************************************************************80
!
!! NCHOSE combines difference factors from a Box-Jenkins time series model.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer i
  integer k
  integer kk
  integer n
  integer nchose
  integer nn

  if ( n <= k ) then
    nchose = 1
    return
  end if

  kk = min ( k, n - k )
  nn = 1
  do i = 1, kk
     nn = ( nn * ( n - i + 1 ) ) / i
  end do

  nchose = nn

  return
end
subroutine nl2itr ( d, iv, j, n, nn, p, r, v, x )

!*****************************************************************************80
!
!! NL2ITR carries out iterations for NL2SOL.
!
!  Discussion:
!
!    Parameters IV, N, P, V, and X are the same as the corresponding
!    ones to NL2SOL, except that V can be shorter, since the part of V
!    that NL2SOL uses for storing D, J, and R is not needed.
!
!    Moreover, compared with NL2SOL, IV(1) may have the
!    two additional output values 1 and 2, which are explained below,
!    as is the use of IV(TOOBIG) and IV(NFGCAL).  The values IV(D),
!    IV(J), and IV(R), which are output values from NL2SOL (and
!    NL2SNO), are not referenced by NL2ITR or the subroutines it calls.
!
!    On a fresh start, that is, a call on NL2ITR with IV(1) = 0 or 12,
!    NL2ITR assumes that R = R(X), the residual at X, and J = J(X),
!    the corresponding jacobian matrix of R at X.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
! iv(1) = 1 means the caller should set r to r(x), the residual at x,
!             and call nl2itr again, having changed none of the other
!             parameters.  an exception occurs if r cannot be evaluated
!             at x (e.g. if r would overflow), which may happen because
!             of an oversized step.  in this case the caller should set
!             iv(toobig) = iv(2) to 1, which will cause nl2itr to ig-
!             nore r and try a smaller step.  the parameter nf that
!             nl2sol passes to CALCR (for possible use by calcj) is a
!             copy of iv(nfcall) = iv(6).
! iv(1) = 2 means the caller should set j to j(x), the jacobian matrix
!             of r at x, and call nl2itr again.  the caller may change
!             d at this time, but should not change any of the other
!             parameters.  the parameter nf that nl2sol passes to
!             calcj is iv(nfgcal) = iv(7).  if j cannot be evaluated
!             at x, then the caller may set iv(nfgcal) to 0, in which
!             case nl2itr will return with iv(1) = 15.
!
!  Parameters:
!
!    Input, real D(N), the scale vector.
!
!    Input/output, integer IV(*), the NL2SOL integer parameter array.
!
!    j   n by p jacobian matrix (lead dimension nn).
!
!    n   number of observations (components in r).
!
!    nn  lead dimension of j.
!
!    p   number of parameters (components in x).
!
!    r   residual vector.
!
!    v   floating-point value array.
!
!    x   parameter vector.
!
  implicit none

  integer n
  integer nn
  integer p

  real d(p)
  integer dig1
  real dotprd
  real e
  integer g01
  integer g1
  integer h0
  integer h1
  integer i
  integer ipiv1
  integer ipivi
  integer ipivk
  integer ipk
  integer iv(60+p)
  real j(nn,p)
  integer k
  integer km1
  integer l
  integer lky1
  integer lmat1
  integer lstgst
  integer m
  integer pp1o2
  integer qtr1
  real r(n)
  integer rd0
  integer rd1
  integer rdk
  real rdof1
  integer rsave1
  integer s1
  integer smh
  integer sstep
  integer step1
  logical stopx
  integer stpmod
  integer, parameter :: stppar = 5
  real sttsst
  real t
  real t1
  integer temp1
  integer temp2
  real v(93 + 2*n + (p*(3*p+31))/2)
  real v2norm
  integer w1
  real x(p)
  integer x01
!
!  external functions and subroutines
!
      external assess, covclc, dotprd, dupdat, gqtstp, itsmry, lmstep, &
               parchk, qapply, rptmul, slupdt, slvmul, stopx, &
               v2norm
!
! subscripts for iv and v
!
      integer cnvcod, cosmin, covmat, covprt, covreq, dgnorm, dig, &
              dinit, dstnrm, dtype, d0init, f, fdif, fuzz, &
              f0, g, gtstep, h, ierr, incfac, inits, ipivot, ipiv0, irc, &
              jtinit, jtol1, kagqt, kalm, lky, lmat, lmax0, mode, model, &
              mxfcal, mxiter, nfcall, nfgcal, nfcov, ngcov, ngcall, &
              niter, nvsave, phmxfc, preduc, qtr, radfac, radinc, &
              radius, rad0, rd, restor, rlimit, rsave, s, size, step, &
              stglim, stlstg, sused, switch, toobig, tuner4, &
              tuner5, vsave1, w, wscale, xirc, x0
!
! iv subscript values
!
  parameter ( cnvcod=34, covmat=26, covprt=14 )
  parameter (covreq=15, dig=43, dtype=16, g=28, h=44 )
  parameter (ierr=32, inits=25, ipivot=61, ipiv0=60 )
  parameter (irc=3, kagqt=35, kalm=36, lky=37, lmat=58 )
  parameter (mode=38, model=5, mxfcal=17, mxiter=18 )
  parameter (nfcall=6, nfgcal=7, nfcov=40, ngcov=41 )
  parameter (ngcall=30, niter=31, qtr=49 )
  parameter (radinc=8, rd=51, restor=9, rsave=52, s=53 )
  parameter (step=55, stglim=11, stlstg=56, sused=57 )
  parameter (switch=12, toobig=2, w=59, xirc=13, x0=60)
!
! v subscript values.
!
     parameter (cosmin=43, dgnorm=1, dinit=38, dstnrm=2)
     parameter ( d0init=37, f=10, fdif=11, fuzz=45 )
    parameter ( f0=13, gtstep=4, incfac=23 )
    parameter ( jtinit=39, jtol1=87, lmax0=35 )
    parameter ( nvsave=9, phmxfc=21, preduc=7 )
    parameter ( radfac=16, radius=8, rad0=9, rlimit=42 )
    parameter ( size=47, tuner4=29, tuner5=30 )
    parameter ( vsave1=78, wscale=48)

  i = iv(1)

      if ( i == 1 ) then
        go to 20
      end if

      if ( i == 2 ) then
        go to 50
      end if
!
!  Check validity of iv and v input values.
!
!  If iv(1) = 0, then PARCHK calls dfault(iv, v).
!
      call parchk ( iv, n, nn, p, v )
      i = iv(1) - 2

      if ( 10 < i ) then
        return
      end if

      go to (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), i
!
!  Initialization and storage allocation.
!
 10   continue

      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
!
!  Length of w = p*(p+9)/2 + 7.  lmat is contained in w.
!
      if ( 0.0E+00 <= v(dinit) ) then
        d(1:p) = v(dinit)
      end if

      if ( 0.0E+00 < v(jtinit) ) then
        v(jtol1:jtol1+p-1) = v(jtinit)
      end if

      i = jtol1 + p

      if ( 0.0E+00 < v(d0init) ) then
        v(i:i+p-1) = v(d0init)
      end if

      v(rad0) = 0.0E+00
      v(stppar) = 0.0E+00
      v(radius) = v(lmax0) / ( 1.0E+00 + v(phmxfc) )
!
!  Set initial model and S matrix.
!
      iv(model) = 1
      if ( iv(inits) == 2 ) then
        iv(model) = 2
      end if

      s1 = iv(s)
      if ( iv(inits) == 0 ) then
        v(s1:s1+pp1o2-1) = 0.0E+00
      end if
!
!  Compute function value (half the sum of squares).
!
 20   continue

      t = v2norm ( n, r )

      if ( v(rlimit) < t ) then
        iv(toobig) = 1
      end if

      if ( iv(toobig) == 0 ) then
        v(f) = 0.5E+00 * t**2
      end if

!30   continue

      if ( iv(mode) == 0 ) then
        go to 350
      end if

      if ( 0 < iv(mode) ) then
        go to 730
      end if

!40   continue

      if ( iv(toobig) /= 0 ) then
         iv(1) = 13
         call itsmry ( d, iv, p, v, x )
         return
      end if

      go to 60
!
!  Make sure jacobian could be computed.
!
 50   continue

      if ( iv(nfgcal) == 0 ) then
         iv(1) = 15
         call itsmry ( d, iv, p, v, x )
         return
      end if
!
!  Compute gradient.
!
 60   continue

      iv(kalm) = -1
      g1 = iv(g)
      do i = 1, p
         v(g1) = dot_product ( r(1:n), j(1:n,i) )
         g1 = g1 + 1
      end do

      if ( 0 < iv(mode) ) then
        go to 710
      end if
!
!  Update D and make copies of R for possible use later.
!
      if ( 0 < iv(dtype) ) then
        call dupdat ( d, iv, j, n, nn, p, v )
      end if

      rsave1 = iv(rsave)
      v(rsave1:rsave1+n-1) = r(1:n)
      qtr1 = iv(qtr)
      v(qtr1:qtr1+n-1) = r(1:n)
!
!  Compute inverse ( D ) * gradient.
!
      g1 = iv(g)
      dig1 = iv(dig)
      k = dig1

      do i = 1, p
         v(k) = v(g1) / d(i)
         k = k + 1
         g1 = g1 + 1
      end do

      v(dgnorm) = v2norm ( p, v(dig1) )

      if ( iv(cnvcod) /= 0 ) then
        go to 700
      end if

      if ( iv(mode) == 0 ) then
        go to 570
      end if

      iv(mode) = 0
!
!  Main loop.
!
!  Print iteration summary, check iteration limit.
!
 150  continue

      call itsmry ( d, iv, p, v, x )

 160  k = iv(niter)

      if ( iv(mxiter) <= k ) then
         iv(1) = 10
         call itsmry ( d, iv, p, v, x )
         return
      end if

170   continue

      iv(niter) = k + 1
!
!  Update radius.
!
      if ( k /= 0 ) then

        step1 = iv(step)
        do i = 1, p
          v(step1) = d(i) * v(step1)
          step1 = step1 + 1
        end do
        step1 = iv(step)
        v(radius) = v(radfac) * v2norm ( p, v(step1) )

      end if
!
!  Initialize for start of next iteration.
!
      x01 = iv(x0)
      v(f0) = v(f)
      iv(kagqt) = -1
      iv(irc) = 4
      iv(h) = -abs ( iv(h) )
      iv(sused) = iv(model)
!
!  Copy X to X0.
!
      v(x01:x01+p-1) = x(1:p)
!
!  Check STOPX and function evaluation limit.
!
 190  if ( .not. stopx ( ) ) then
        go to 200
      end if

         iv(1) = 11
         go to 205
!
!  Come here when restarting after function evaluation limit or STOPX.
!
 195  continue

      if ( v(f) < v(f0) ) then
         v(radfac) = 1.0E+00
         k = iv(niter)
         go to 170
      end if

 200  continue

      if ( iv(nfcall) < iv(mxfcal) + iv(nfcov) ) then
        go to 210
      end if

         iv(1) = 9
 205     continue

         if ( v(f0) <= v(f) ) then
           call itsmry ( d, iv, p, v, x )
           return
         end if
!
!  In case of STOPX or function evaluation limit with
!  improved V(F), evaluate the gradient at X.
!
         iv(cnvcod) = iv(1)
         go to 560
!
!  Compute candidate step.
!
 210  continue

      step1 = iv(step)
      w1 = iv(w)
!
!  Compute Levenberg-Marquardt step.
!
      if ( iv(model) /= 2 ) then

         qtr1 = iv(qtr)

         if ( iv(kalm) < 0 ) then

           rd1 = iv(rd)

           if ( -1 == iv(kalm) ) then
             call qrfact ( nn, n, p, j, v(rd1), iv(ipivot), iv(ierr), &
               0, v(w1) )
           end if

           call qapply ( nn, n, p, j, v(qtr1), iv(ierr) )

         end if

         h1 = iv(h)
!
!  Copy R matrix to H.
!
         if ( h1 <= 0 ) then

              h1 = -h1
              iv(h) = h1
              k = h1
              rd1 = iv(rd)
              v(k) = v(rd1)

              do i = 2, p
                   call vcopy ( i-1, v(k+1), j(1,i) )
                   k = k + i
                   rd1 = rd1 + 1
                   v(k) = v(rd1)
              end do
         end if

         g1 = iv(g)
         call lmstep ( d, v(g1), iv(ierr), iv(ipivot), iv(kalm), p, &
           v(qtr1), v(h1), v(step1), v, v(w1) )
!
!  Compute Goldfeld-Quandt-Trotter step (augmented model).
!
      else

      if ( iv(h) <= 0 ) then
!
!  Set H to inverse ( D ) * ( J' * J + s) ) * inverse ( D ).
!
        h1 = -iv(h)
        iv(h) = h1
        s1 = iv(s)
!
!  J is in its original form.
!
        if ( iv(kalm) == -1 ) then

          do i = 1, p
            t = 1.0E+00 / d(i)
            do k = 1, i
              v(h1) = t * ( dotprd ( n, j(1,i), j(1,k) ) + v(s1) ) / d(k)
              h1 = h1 + 1
              s1 = s1 + 1
            end do
          end do
!
!  LMSTEP has applied QRFACT to J.
!
        else

          smh = s1 - h1
          h0 = h1 - 1
          ipiv1 = iv(ipivot)
          t1 = 1.0E+00 / d(ipiv1)
          rd0 = iv(rd) - 1
          rdof1 = v(rd0 + 1)

          do i = 1, p

            l = ipiv0 + i
            ipivi = iv(l)
            h1 = h0 + ( ipivi*(ipivi-1) ) / 2
            l = h1 + ipivi
            m = l + smh
!
!  v(l) = h(ipivot(i), ipivot(i))
!  v(m) = s(ipivot(i), ipivot(i))
!
            t = 1.0E+00 / d(ipivi)
            rdk = rd0 + i
            e = v(rdk)**2
            if ( 1 < i ) then
              e = e + dotprd ( i-1, j(1,i), j(1,i) )
            end if
            v(l) = (e + v(m)) * t**2

            if ( i /= 1 ) then

              l = h1 + ipiv1
              if ( ipivi < ipiv1 ) then
                l = l + ((ipiv1-ipivi)*(ipiv1+ipivi-3)) / 2
              end if
              m = l + smh
!
!  v(l) = h(ipivot(i), ipivot(1))
!  v(m) = s(ipivot(i), ipivot(1))
!
              v(l) = t * (rdof1 * j(1,i)  +  v(m)) * t1

              do k = 2, i - 1
                ipk = ipiv0 + k
                ipivk = iv(ipk)
                l = h1 + ipivk
                if ( ipivi < ipivk ) then
                  l = l + ((ipivk-ipivi)*(ipivk+ipivi-3)) / 2
                end if
                m = l + smh
!
!  v(l) = h(ipivot(i), ipivot(k))
!  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)
              end do

            end if

          end do

        end if

      end if
!
!  Compute actual Goldfeld-Quandt-Trotter step.
!
      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) )
    end if
!
!  Compute R(X0 + STEP).
!
!310  continue

      if ( iv(irc) /= 6 ) then
        x01 = iv(x0)
        step1 = iv(step)
        x(1:p) = v(step1:step1+p-1) + v(x01:x01+p-1)
        iv(nfcall) = iv(nfcall) + 1
        iv(1) = 1
        iv(toobig) = 0
        return
      end if
!
!  Assess candidate step.
!
350   continue

      step1 = iv(step)
      lstgst = iv(stlstg)
      x01 = iv(x0)
      call assess ( d, iv, p, v(step1), v(lstgst), v, x, v(x01) )
!
!  If necessary, switch models and/or restore R.
!
      if ( iv(switch) /= 0 ) then
        iv(h) = -abs ( iv(h) )
        iv(sused) = iv(sused) + 2
        v(1:nvsave) = v(vsave1:vsave1+nvsave-1)
      end if

!360  continue

      if ( iv(restor) /= 0 ) then
         rsave1 = iv(rsave)
         r(1:n) = v(rsave1:rsave1+n-1)
      end if

      l = iv(irc) - 4
      stpmod = iv(model)

      if ( 0 < l ) then
        go to (410,440,450,450,450,450,450,450,640,570), l
      end if
!
!  Decide whether to change models.
!
      e = v(preduc) - v(fdif)
      sstep = iv(lky)
      s1 = iv(s)
      call slvmul ( p, v(sstep), v(s1), v(step1) )
      sttsst = 0.5E+00 * dotprd ( p, v(step1), v(sstep) )

      if ( iv(model) == 1 ) then
        sttsst = -sttsst
      end if
!
!  Switch models.
!
      if ( abs ( e ) <= abs ( e + sttsst) * v(fuzz) ) then
        go to 400
      end if

         iv(model) = 3 - iv(model)

         if ( iv(model) == 1 ) then
           iv(kagqt) = -1
         end if

         if (iv(model) == 2 .and. 0 < iv(kalm) ) then
           iv(kalm) = 0
         end if

         if ( -2 < l ) then
           go to 480
         end if

              iv(h) = -abs ( iv(h) )
              iv(sused) = iv(sused) + 2
              v(vsave1:vsave1+nvsave-1) = v(1:nvsave)
              go to 420

 400  if ( -3 < l ) then
        go to 480
      end if
!
!  Recompute STEP with decreased radius.
!
         v(radius) = v(radfac) * v(dstnrm)
         go to 190
!
!  Recompute STEP, saving V values and R if necessary.
!
 410  continue

      v(radius) = v(radfac) * v(dstnrm)

 420  continue

      if ( v(f) < v(f0) ) then
        rsave1 = iv(rsave)
        v(rsave1:rsave1+n-1) = r(1:n)
      end if

      go to 190
!
!  Compute step of length V(LMAX0) for singular convergence test.
!
 440  continue

      v(radius) = v(lmax0)
      go to 210
!
!  Convergence or false convergence.
!
 450  continue

      iv(cnvcod) = l
      if ( v(f0) <= v(f) ) then
        go to 700
      end if

         if ( iv(xirc) == 14 ) then
           go to 700
         end if

              iv(xirc) = 14
!
!  Process acceptable step.
!
 480  iv(covmat) = 0
!
!  Set LKY = J(X0)' * R(X).
!
      lky1 = iv(lky)
!
!  Jacobian has not been modified.
!
      if ( iv(kalm) < 0 ) then

         do i = 1, p
           v(lky1) = dotprd ( n, j(1,i), r )
           lky1 = lky1 + 1
         end do
!
!  QRFACT has been applied to J.  Store copy of R in QTR and
!  apply Q to it.
!
      else

        qtr1 = iv(qtr)
        v(qtr1:qtr1+n-1) = r(1:n)
        call qapply ( nn, n, p, j, v(qtr1), iv(ierr) )
!
!  Multiply top P-vector in QTR by permuted upper triangle
!  stored by QRFACT in J and RD.
!
        rd1 = iv(rd)
        temp1 = iv(stlstg)
        call rptmul ( 3, iv(ipivot), j, nn, p, v(rd1), v(qtr1), v(lky1), &
          v(temp1) )

      end if
!
!  See whether to set V(RADFAC) by gradient tests.
!
!510  continue

      if ( iv(irc) == 3 ) then

        step1 = iv(step)
        temp1 = iv(stlstg)
        temp2 = iv(x0)
!
!  Set TEMP1 = hessian * STEP for use in gradient tests
!
!  STEP computed using Gauss-Newton model.
!  QRFACT has been applied to J.
!
        if ( stpmod /= 2 ) then

          rd1 = iv(rd)
          call rptmul ( 2, iv(ipivot), j, nn, p, v(rd1), &
            v(step1), v(temp1), v(temp2) )
!
!  STEP computed using augmented model.
!
        else

          h1 = iv(h)
          k = temp2

          do i = 1, p
            v(k) = d(i) * v(step1)
            k = k + 1
            step1 = step1 + 1
          end do

          call slvmul ( p, v(temp1), v(h1), v(temp2) )

          do i = 1, p
            v(temp1) = d(i) * v(temp1)
            temp1 = temp1 + 1
          end do

        end if

      end if
!
!  Save old gradient and compute new one.
!
 560  continue

      iv(ngcall) = iv(ngcall) + 1
      g1 = iv(g)
      g01 = iv(w)
      v(g01:g01+p-1) = v(g1:g1+p-1)
      iv(1) = 2
      return
!
!  Initializations -- g0 = g - g0, etc.
!
 570  continue

      g01 = iv(w)
      g1 = iv(g)
      v(g01:g01+p-1) = - v(g01:g01+p-1) + v(g1:g1+p-1)
      step1 = iv(step)
      temp1 = iv(stlstg)
      temp2 = iv(x0)
!
!  Set V(RADFAC) by gradient tests.
!
!  Set TEMP1 = d**-1 * (hessian * STEP  +  ( G(x0) - G(x) ) ).
!
      if ( iv(irc) == 3 ) then

         k = temp1
         l = g01
         do i = 1, p
           v(k) = (v(k) - v(l)) / d(i)
           k = k + 1
           l = l + 1
         end do
!
!  Do gradient tests.
!
         if ( v2norm ( p, v(temp1) ) <= v(dgnorm) * v(tuner4) .or. &
           dotprd ( p, v(g1), v(step1) ) < v(gtstep) * v(tuner5) ) then
           v(radfac) = v(incfac)
         end if

      end if
!
!  Finish computing LKY = ( J(X) - J(X0) )' * R.
!
!  Currently LKY = J(X0)' * R.
!
      lky1 = iv(lky)
      v(lky1:lky1+p-1) = - v(lky1:lky1+p-1) + v(g1:g1+p-1)
!
!  Determine sizing factor V(SIZE).
!
!  Set TEMP1 = S * STEP.
!
      s1 = iv(s)
      call slvmul ( p, v(temp1), v(s1), v(step1) )

      t1 = abs ( dotprd ( p, v(step1), v(temp1) ) )
      t = abs ( dotprd ( p, v(step1), v(lky1) ) )
      v(size) = 1.0E+00

      if ( t < t1 ) then
        v(size) = t / t1
      end if
!
!  Update S.
!
      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
!
!  Bad parameters to ASSESS.
!
 640  iv(1) = 14
      call itsmry ( d, iv, p, v, x )
      return
!
!  Convergence obtained.  Compute covariance matrix if desired.
!
 700  continue

      if ( ( iv(covreq) == 0 .and. iv(covprt) == 0 ) .or. &
        iv(covmat) /= 0 .or. &
        7 <= iv(cnvcod) ) then
        iv(1) = iv(cnvcod)
        iv(cnvcod) = 0
        call itsmry ( d, iv, p, v, x )
        return
      end if

      iv(mode) = 0

 710  continue

      call covclc ( i, d, iv, j, n, nn, p, r, v, x )

      if ( i == 3 ) then

        iv(ngcov) = iv(ngcov) + 1
        iv(ngcall) = iv(ngcall) + 1
        iv(1) = 2

      else if ( i == 4 ) then

        if ( iv(niter) == 0 ) then
          iv(mode) = -1
        else
          iv(mode) = 0
        end if

        iv(1) = iv(cnvcod)
        iv(cnvcod) = 0

        call itsmry ( d, iv, p, v, x )

      else

        iv(nfcov) = iv(nfcov) + 1
        iv(nfcall) = iv(nfcall) + 1
        iv(restor) = i
        iv(1) = 1

      end if

      return

 730  continue

  if ( iv(restor) == 1 .or. iv(toobig) /= 0 ) then
    go to 710
  end if

  iv(nfgcal) = iv(nfcall)
  iv(ngcov) = iv(ngcov) + 1
  iv(ngcall) = iv(ngcall) + 1
  iv(1) = 2

  return
end
subroutine nl2sno ( n, p, x, calcr, iv, v, uiparm, urparm, ufparm )

!*****************************************************************************80
!
!! NL2SNO is like NL2SOL, but uses a finite difference jacobian.
!
!  Discussion:
!
!    NL2SNO is like NL2SOL, but without calcj -- minimize nonlinear sum of
!    squares using finite-difference jacobian approximations
!
!    The parameters for NL2SNO are the same as those for NL2SOL
!    except that CALCJ is omitted.  Instead of calling
!    CALCJ to obtain the jacobian matrix of R at X, NL2SNO computes
!    an approximation to it by forward finite differences.  See
!    V(DLTFDJ) below.  NL2SNO uses function values only when comput-
!    the covariance matrix, rather than the functions and gradients
!    that NL2SOL may use.  To do so, NL2SNO sets IV(COVREQ) to -1 if
!    IV(COVPRT) = 1 with IV(COVREQ) = 0 and to minus its absolute
!    value otherwise.  Thus V(DELTA0) is never referenced and only
!    V(DLTFDC) matters.  See NL2SOL for a description of V(DLTFDC).
!
!    The number of extra calls on CALCR used in computing the jacobian
!    approximation are not included in the function evaluation
!    count IV(NFCALL) and are not otherwise reported.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
!  Parameters:
!
!    V(DLTFDJ) helps choose the step size used when computing the
!    finite-difference jacobian matrix.  For differences involving X(I),
!    the step size first tried is
!      V(DLTFDJ) * max ( abs ( X(I) ), 1/D(I)),
!    where D is the current scale vector; see reference 1.  If this step is
!    too big, so that CALCR sets NF to 0, then smaller steps are tried
!    until the step size is shrunk below 1000 * MACHEP, where MACHEP
!    is the unit roundoff.  Default = sqrt ( MACHEP ).
!
  implicit none

  integer p

  external calcr
  integer, parameter :: covprt = 14
  integer, parameter :: covreq = 15
  integer, parameter :: d = 27
  integer d1
  integer, parameter :: dinit = 38
  integer dk
  integer, parameter :: dltfdj = 36
  integer, parameter :: dtype = 16
  real h
  real, parameter :: hfac = 1000.0E+00
  real, save :: hlim = 0.0E+00
  integer i
  integer iv(60+p)
  integer, parameter :: j = 33
  integer j1
  integer j1k
  integer k
  integer n
  integer nf
  integer, parameter :: nfcall = 6
  integer, parameter :: nfgcal = 7
  integer, parameter :: r = 50
  integer r1
  integer rn
  logical strted
  integer, parameter :: toobig = 2
  external ufparm
  integer uiparm(*)
  real urparm(*)
  real v(93 + n*p + 3*n + (p*(3*p+33))/2)
  real x(p)
  real xk

  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) == 0 ) then
    call dfault ( iv, v )
  end if

  iv(covreq) = -abs ( iv(covreq) )
  if ( iv(covprt) /= 0 .and. iv(covreq) == 0 ) then
    iv(covreq) = -1
  end if

  strted = .true.

  if ( iv(1) /= 12 ) then
    go to 80
  end if

  strted = .false.
  iv(nfcall) = 1
  iv(nfgcal) = 1
!
!  Initialize scale vector D to ones for computing initial jacobian.
!
  if ( 0 < iv(dtype) ) then
    v(d1:d1+p-1) = 1.0E+00
  end if

10 continue

  nf = iv(nfcall)

  call calcr ( n, p, x, nf, v(r1), uiparm, urparm, ufparm )

  if ( strted ) then

    if ( nf <= 0 ) then
      iv(toobig) = 1
    end if

    go to 80

  end if

  if ( nf <= 0 ) then
    iv(1) = 13
    call itsmry ( v(d1), iv, p, v, x )
    return
  end if
!
!  Compute finite-difference jacobian.
!
30 continue

  j1k = j1
  dk = d1

  do k = 1, p

    xk = x(k)
    h = v(dltfdj) * max ( abs ( xk ), 1.0E+00 / v(dk) )
    dk = dk + 1

    do

      x(k) = xk + h
      nf = iv(nfgcal)
      call calcr ( n, p, x, nf, v(j1k), uiparm, urparm, ufparm )

      if ( 0 < nf ) then
        exit
      end if

      if ( hlim == 0.0E+00 ) then
        hlim = hfac * epsilon ( hlim )
      end if

      h = -0.5E+00 * h

      if ( abs ( h ) < hlim ) then
        iv(1) = 15
        call itsmry ( v(d1), iv, p, v, x )
        return
      end if

    end do

    x(k) = xk

    do i = r1, rn
      v(j1k) = ( v(j1k) - v(i) ) / h
      j1k = j1k + 1
    end do

  end do

  strted = .true.

80 continue

  call nl2itr ( v(d1), iv, v(j1), n, n, p, v(r1), v, x )

  if ( iv(1) < 2 ) then
    go to 10
  else if ( iv(1) == 2 ) then
    go to 30
  end if

  return
end
subroutine nl2sol ( n, p, x, calcr, calcj, iv, v, uiparm, urparm, ufparm )

!*****************************************************************************80
!
!! NL2SOL minimizes a nonlinear sum of squares using an analytic jacobian.
!
!  Purpose:
!
!    Given a P-vector X of parameters, CALCR computes an N-vector
!    R = R(X) of residuals corresponding to X.  R(X) probably arises
!    from a nonlinear model involving P parameters and N observations.
!
!    This routine interacts with NL2ITR to seek a parameter vector X
!    that minimizes the sum of the squares of the components of R(X),
!    i.e., that minimizes the sum-of-squares function
!    F(X) = R(X)' * R(X) / 2.  R(X) is assumed to be a twice
!    continuously differentiable function of X.
!
!    See reference 1 for a description of the algorithm used.
!    On problems which are naturally well scaled, better performance
!    may be obtained by setting V(D0INIT) = 1.0 and IV(DTYPE) = 0,
!    which will cause the scale vector D to be set to all ones.
!
!    After a return with IV(1) <= 11, it is possible to restart,
!    that is, to change some of the IV and V input values and continue
!    the algorithm from the point where it was interrupted.  IV(1)
!    should not be changed, nor should any entries of IV
!    and V other than the input values (those supplied by DFAULT).
!
!    Those who do not wish to write a CALCJ which computes the jacobian
!    matrix analytically should call NL2SNO rather than NL2SOL.
!    NL2SNO uses finite differences to compute an approximate jacobian.
!
!    Those who would prefer to provide R and J (the residual and
!    jacobian) by reverse communication rather than by writing subroutines
!    CALCR and CALCJ may call on NL2ITR directly.  See the comments at the
!    beginning of NL2ITR.
!
!    Those who use NL2SOL interactively may wish to supply their
!    own STOPX function, which should return TRUE if the break key
!    has been pressed since stopx was last invoked.  This makes it possible
!    to externally interrupt NL2SOL (which will return with
!    IV(1) = 11 if STOPX returns TRUE).
!
!    Storage for J is allocated at the end of V.  Thus the caller
!    may make V longer than specified above and may allow CALCJ to use
!    elements of J beyond the first N*P as scratch storage.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
!  Parameters:
!
!    Input, integer N, the number of observations, that is, the number of
!    components in R(X).  P <= N.
!
!    Input, integer P, the number of parameters, or components in X.  P must
!    be positive.
!
!    Input/output, real X(P).  On input, X is an initial guess at the
!    desired parameter estimate.  On output, X contains the best parameter
!    estimate found.
!
!    Input, external CALCR, a subroutine which, given X, computes R(X).
!    CALCR must be declared external in the calling program.
!    It is invoked by
!      call calcr ( n, p, x, nf, r, uiparm, urparm, ufparm )
!    When CALCR is called, NF is the invocation count for CALCR.  It is
!    included for possible use with CALCJ.  If X is out of bounds, for
!    instance, if it would cause overflow in computing R(X), then CALCR
!    should set NF to 0.  This will cause a shorter step to be attempted.
!    The other parameters are as described above and below.  CALCR
!    should not change N, P, or X.
!
!    Input, external CALCJ, a subroutine which, given X, computes the
!    jacobian matrix J of R at X, that is, the N by P matrix whose
!    (I,K) entry is the partial derivative of the I-th component of R
!    with respect to X(K).  CALCJ must be declared external in the
!    calling program.  It is invoked by
!      call calcj(n,p,x,nf,j,uiparm,urparm,ufparm)
!    NF is the invocation count for CALCR at the time R(X) was evaluated.
!    The X passed to CALCJ is usually the one passed to CALC on either its
!    most recent invocation or the one prior to it.  If CALCR saves
!    intermediate results for use by CALCJ, then it is possible to tell
!    from NF whether they are valid for the current X (or which copy is
!    valid if two copies are kept).  If J cannot be computed at X,
!    then CALCJ should set NF to 0.  In this case, NL2SOL will return
!    with IV(1) = 15.  The other parameters to CALCJ are as described
!    above and below.  CALCJ should not change N, P, or X.
!
!    Input/output, integer IV(60+P), helps control the NL2SOL algorithm
!    and is used to store various intermediate quantities.  Of particular
!    interest are the initialization/return code IV(1) and the entries
!    in that control printing and limit the number of iterations and
!    function evaluations.  See the section on IV input values.
!
! v........ (input/output) a floating-point value array of length at
!                  least 93 + n*p + 3*n + p*(3*p+33)/2 that helps con-
!                  trol the nl2sol algorithm and that is used to store
!                  various intermediate quantities.  of particular in-
!                  terest are the entries in v that limit the length of
!                  the first step attempted (lmax0), specify conver-
!                  gence tolerances (afctol, rfctol, xctol, xftol),
!                  and help choose the step size used in computing the
!                  covariance matrix (delta0).  see the section on
!                  (selected) v input values below.
!
! uiparm... (input) user integer parameter array passed without change
!                  to calcr and calcj.
!
! urparm... (input) user floating-point parameter array passed without
!                  change to calcr and calcj.
!
! ufparm... (input) user external subroutine or function passed without
!                  change to calcr and calcj.
!
!  iv input values (from subroutine dfault)
!
! iv(1)...  on input, iv(1) should have a value between 0 and 12......
!             0 and 12 mean this is a fresh start.  0 means that
!             dfault(iv, v) is to be called to provide all default
!             values to iv and v.  12 (the value that dfault assigns to
!             iv(1)) means the caller has already called dfault(iv, v)
!             and has possibly changed some iv and/or v entries to non-
!             default values.  default = 12.
! iv(covprt)... iv(14) = 1 means print a covariance matrix at the solu-
!             tion.  (this matrix is computed just before a return with
!             iv(1) = 3, 4, 5, 6.)
!             iv(covprt) = 0 means skip this printing.  default = 1.
! iv(covreq)... iv(15) = nonzero means compute a covariance matrix
!             just before a return with iv(1) = 3, 4, 5, 6.  in
!             this case, an approximate covariance matrix is obtained
!             in one of several ways.  let k = abs(iv(covreq)) and let
!             scale = 2*f(x)/max(1,n-p),  where 2*f(x) is the residual
!             sum of squares.  if k = 1 or 2, then a finite-difference
!             hessian approximation h is obtained.  if h is positive
!             definite (or, for k = 3, if the jacobian matrix j at x
!             is nonsingular), then one of the following is computed...
!                  k = 1....  scale * h**-1 * (j**t * j) * h**-1.
!                  k = 2....  scale * h**-1.
!                  k = 3....  scale * (j**t * j)**-1.
!             (j**t is the transpose of j, while **-1 means inverse.)
!             if iv(covreq) is positive, then both function and grad-
!             ient values (calls on calcr and calcj) are used in com-
!             puting h (with step sizes determined using v(delta0) --
!             see below), while if iv(covreq) is negative, then only
!             function values (calls on calcr) are used (with step
!             sizes determined using v(dltfdc) -- see below).  if
!             iv(covreq) = 0, then no attempt is made to compute a co-
!             variance matrix (unless iv(covprt) = 1, in which case
!             iv(covreq) = 1 is assumed).  see iv(covmat) below.
!             default = 1.
! iv(dtype).... iv(16) tells how the scale vector D (see ref. 1) should
!             be chosen.  1 <= iv(dtype) means choose d as described
!             below with v(dfac).  iv(dtype) <= 0 means the caller
!             has chosen d and has stored it in v starting at
!             v(94 + 2*n + p*(3*p + 31)/2).  default = 1.
! iv(inits).... iv(25) tells how the S matrix (see ref. 1) should be
!             initialized.  0 means initialize S to 0 (and start with
!             the Gauss-Newton model).  1 and 2 mean that the caller
!             has stored the lower triangle of the initial S rowwise in
!             v starting at v(87+2*p).  iv(inits) = 1 means start with
!             the Gauss-Newton model, while iv(inits) = 2 means start
!             with the augmented model (see ref. 1).  default = 0.
! iv(mxfcal)... iv(17) gives the maximum number of function evaluations
!             (calls on calcr, excluding those used to compute the co-
!             variance matrix) allowed.  if this number does not suf-
!             fice, then nl2sol returns with iv(1) = 9.  default = 200.
! iv(mxiter)... iv(18) gives the maximum number of iterations allowed.
!             it also indirectly limits the number of gradient evalua-
!             tions (calls on calcj, excluding those used to compute
!             the covariance matrix) to iv(mxiter) + 1.  if iv(mxiter)
!             iterations do not suffice, then nl2sol returns with
!             iv(1) = 10.  default = 150.
! iv(outlev)... iv(19) controls the number and length of iteration sum-
!             mary lines printed (by itsmry).  iv(outlev) = 0 means do
!             not print any summary lines.  otherwise, print a summary
!             line after each abs(iv(outlev)) iterations.  if iv(outlev)
!             is positive, then summary lines of length 117 (plus carri-
!             age control) are printed, including the following...  the
!             iteration and function evaluation counts, current func-
!             tion value (v(f) = half the sum of squares), relative
!             difference in function values achieved by the latest step
!             (i.e., reldf = (f0-v(f))/f0, where f0 is the function
!             value from the previous iteration), the relative function
!             reduction predicted for the step just taken (i.e.,
!             preldf = v(preduc) / f0, where v(preduc) is described
!             below), the scaled relative change in x (see v(reldx)
!             below), the models used in the current iteration (g =
!             Gauss-Newton, s=augmented), the Marquardt parameter
!             STPPAR used in computing the last step, the sizing factor
!             used in updating s, the 2-norm of the scale vector d
!             times the step just taken (see ref. 1), and npreldf, i.e.,
!             v(nreduc)/f0, where v(nreduc) is described below -- if
!             npreldf is positive, then it is the relative function
!             reduction predicted for a Newton step (one with
!             STPPAR = 0).  if npreldf is zero, either the gradient
!             vanishes (as does preldf) or else the augmented model
!             is being used and its hessian is indefinite (with preldf
!             positive).  if npreldf is negative, then it is the nega-
!             of the relative function reduction predicted for a step
!             computed with step bound v(lmax0) for use in testing for
!             singular convergence.
!                  if iv(outlev) is negative, then lines of maximum
!             length 79 (or 55 is iv(covprt) = 0) are printed, includ-
!             ing only the first 6 items listed above (through reldx).
!             default = 1.
! iv(parprt)... iv(20) = 1 means print any nondefault v values on a
!             fresh start or any changed v values on a restart.
!             iv(parprt) = 0 means skip this printing.  default = 1.
! iv(prunit)... iv(21) is the output unit number on which all printing
!             is done.  iv(prunit) = 0 means suppress all printing.
!             (setting iv(prunit) to 0 is the only way to suppress the
!             one-line termination reason message printed by itsmry.)
!             default = standard output unit (unit 6 on most systems).
! iv(solprt)... iv(22) = 1 means print out the value of x returned (as
!             well as the corresponding gradient and scale vector d).
!             iv(solprt) = 0 means skip this printing.  default = 1.
! iv(statpr)... iv(23) = 1 means print summary statistics upon return-
!             ing.  these consist of the function value (half the sum
!             of squares) at x, v(reldx) (see below), the number of
!             function and gradient evaluations (calls on calcr and
!             calcj respectively, excluding any calls used to compute
!             the covariance), the relative function reductions predict-
!             ed for the last step taken and for a Newton step (or per-
!             haps a step bounded by v(lmax0) -- see the descriptions
!             of preldf and npreldf under iv(outlev) above), and (if an
!             attempt was made to compute the covariance) the number of
!             calls on calcr and calcj used in trying to compute the
!             covariance.  iv(statpr) = 0 means skip this printing.
!             default = 1.
! iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d
!             (on a fresh start only).  iv(x0prt) = 0 means skip this
!             printing.  default = 1.
!
!  (selected) iv output values
!
! iv(1)........ on output, iv(1) is a return code....
!             3 = x-convergence.  the scaled relative difference be-
!                  tween the current parameter vector x and a locally
!                  optimal parameter vector is very likely at most
!                  v(xctol).
!             4 = relative function convergence.  the relative differ-
!                  ence between the current function value and its lo-
!                  cally optimal value is very likely at most v(rfctol).
!             5 = both x- and relative function convergence (i.e., the
!                  conditions for iv(1) = 3 and iv(1) = 4 both hold).
!             6 = absolute function convergence.  the current function
!                  value is at most v(afctol) in absolute value.
!             7 = singular convergence.  the hessian near the current
!                  iterate appears to be singular or nearly so, and a
!                  step of length at most v(lmax0) is unlikely to yield
!                  a relative function decrease of more than v(rfctol).
!             8 = false convergence.  the iterates appear to be converg-
!                  ing to a noncritical point.  this may mean that the
!                  convergence tolerances (v(afctol), v(rfctol),
!                  v(xctol)) are too small for the accuracy to which
!                  the function and gradient are being computed, that
!                  there is an error in computing the gradient, or that
!                  the function or gradient is discontinuous near x.
!             9 = function evaluation limit reached without other con-
!                  vergence (see iv(mxfcal)).
!            10 = iteration limit reached without other convergence
!                  (see iv(mxiter)).
!            11 = stopx returned .true. (external interrupt).  see the
!                  usage notes below.
!            13 = f(x) cannot be computed at the initial x.
!            14 = bad parameters passed to assess (which should not
!                  occur).
!            15 = the jacobian could not be computed at x (see calcj
!                  above).
!            16 = n or p (or parameter nn to nl2itr) out of range --
!                  p <= 0 or n < p or nn < n.
!            17 = restart attempted with n or p (or par. nn to nl2itr)
!                  changed.
!            18 = iv(inits) is out of range.
!            19...45 = v(iv(1)) is out of range.
!            50 = iv(1) was out of range.
!            87...(86+p) = jtol(iv(1)-86) (i.e., v(iv(1)) is not
!                  positive (see v(dfac) below).
! iv(covmat)... iv(26) tells whether a covariance matrix was computed.
!             if (iv(covmat) is positive, then the lower triangle of
!             the covariance matrix is stored rowwise in v starting at
!             v(iv(covmat)).  if iv(covmat) = 0, then no attempt was
!             made to compute the covariance.  if iv(covmat) = -1,
!             then the finite-difference hessian was indefinite.  and
!             and if iv(covmat) = -2, then a successful finite-differ-
!             encing step could not be found for some component of x
!             (i.e., calcr set nf to 0 for each of two trial steps).
!             note that iv(covmat) is reset to 0 after each successful
!             step, so if such a step is taken after a restart, then
!             the covariance matrix will be recomputed.
! iv(d)........ iv(27) is the starting subscript in v of the current
!             scale vector d.
! iv(g)........ iv(28) is the starting subscript in v of the current
!             least-squares gradient vector (j**t)*r.
! iv(nfcall)... iv(6) is the number of calls so far made on calcr (i.e.,
!             function evaluations, including those used in computing
!             the covariance).
! iv(nfcov).... iv(40) is the number of calls made on calcr when
!             trying to compute covariance matrices.
! iv(ngcall)... iv(30) is the number of gradient evaluations (calls on
!             calcj) so far done (including those used for computing
!             the covariance).
! iv(ngcov).... iv(41) is the number of calls made on calcj when
!             trying to compute covariance matrices.
! iv(niter).... iv(31) is the number of iterations performed.
! iv(r)........ iv(50) is the starting subscript in v of the residual
!             vector r corresponding to x.
!
! (selected) v input values (from subroutine dfault)
!
! v(afctol)... v(31) is the absolute function convergence tolerance.
!             if nl2sol finds a point where the function value (half
!             the sum of squares) is less than v(afctol), and if nl2sol
!             does not return with iv(1) = 3, 4, or 5, then it returns
!             with iv(1) = 6.  default = max(10**-20, machep**2), where
!             machep is the unit roundoff.
! v(delta0)... v(44) is a factor used in choosing the finite-difference
!             step size used in computing the covariance matrix when
!             iv(covreq) = 1 or 2.  for component i, step size
!                  v(delta0) * max(abs(x(i)), 1/d(i)) * sign(x(i))
!             is used, where d is the current scale vector (see ref. 1).
!             (if this step results in calcr setting nf to 0, then -0.5
!             times this step is also tried.)  default = machep**0.5,
!             where machep is the unit roundoff.
! v(dfac)..... v(41) and the d0 and jtol arrays (see v(d0init) and
!             v(jtinit)) are used in updating the scale vector d when
!             0 < iv(dtype).  (d is initialized according to
!             v(dinit).)  let d1(i) =
!               max(sqrt(jcnorm(i)**2 + max(s(i,i),0)), v(dfac)*d(i)),
!             where jcnorm(i) is the 2-norm of the i-th column of the
!             current jacobian matrix and s is the s matrix of ref. 1.
!             if iv(dtype) = 1, then d(i) is set to d1(i) unless
!             d1(i) < jtol(i), in which case d(i) is set to
!                                max(d0(i), jtol(i)).
!             if 2 <= iv(dtype), then d is updated during the first
!             iteration as for iv(dtype) = 1 (after any initialization
!             due to v(dinit)) and is left unchanged thereafter.
!             default = 0.6.
! v(dinit).... v(38), if nonnegative, is the value to which the scale
!             vector d is initialized.  default = 0.
! v(dltfdc)... v(40) helps choose the step size used when computing the
!             covariance matrix when iv(covreq) = -1 or -2.  for
!             differences involving x(i), the step size first tried is
!                       v(dltfdc) * max(abs(x(i)), 1/d(i)),
!             where d is the current scale vector (see ref. 1).  (if
!             this step is too big the first time it is tried, i.e., if
!             calcr sets nf to 0, then -0.5 times this step is also
!             tried.)  default = machep**(1/3), where machep is the
!             unit roundoff.
! v(d0init)... v(37), if positive, is the value to which all components
!             of the d0 vector (see v(dfac)) are initialized.  if
!             v(dfac) = 0, then it is assumed that the caller has
!             stored d0 in v starting at v(p+87).  default = 1.0.
! v(jtinit)... v(39), if positive, is the value to which all components
!             of the jtol array (see v(dfac)) are initialized.  if
!             v(jtinit) = 0, then it is assumed that the caller has
!             stored jtol in v starting at v(87).  default = 10**-6.
! v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the
!             very first step that nl2sol attempts.  it is also used
!             in testing for singular convergence -- if the function
!             reduction predicted for a step of length bounded by
!             v(lmax0) is at most v(rfctol) * abs(f0), where  f0  is
!             the function value at the start of the current iteration,
!             and if nl2sol does not return with iv(1) = 3, 4, 5, or 6,
!             then it returns with iv(1) = 7.    default = 100.
! v(rfctol)... v(32) is the relative function convergence tolerance.
!             if the current model predicts a maximum possible function
!             reduction (see v(nreduc)) of at most v(rfctol)*abs(f0) at
!             the start of the current iteration, where  f0  is the
!             then current function value, and if the last step attempt-
!             ed achieved no more than twice the predicted function
!             decrease, then nl2sol returns with iv(1) = 4 (or 5).
!             default = max(10**-10, machep**(2/3)), where machep is
!             the unit roundoff.
! v(tuner1)... v(26) helps decide when to check for false convergence
!             and to consider switching models.  this is done if the
!             actual function decrease from the current step is no more
!             than v(tuner1) times its predicted value.  default = 0.1.
! v(xctol).... v(33) is the x-convergence tolerance.  if a Newton step
!             (see v(nreduc)) is tried that has v(reldx) <= v(xctol)
!             and if this step yields at most twice the predicted func-
!             tion decrease, then nl2sol returns with iv(1) = 3 (or 5).
!             (see the description of v(reldx) below.)
!             default = machep**0.5, where machep is the unit roundoff.
! v(xftol).... v(34) is the false convergence tolerance.  if a step is
!             tried that gives no more than v(tuner1) times the predict-
!             ed function decrease and that has v(reldx) <= v(xftol),
!             and if nl2sol does not return with iv(1) = 3, 4, 5, 6, or
!             7, then it returns with iv(1) = 8.  (see the description
!             of v(reldx) below.)  default = 100*machep, where
!             machep is the unit roundoff.
! v(*)........ dfault supplies to v a number of tuning constants, with
!             which it should ordinarily be unnecessary to tinker.  see
!             version 2.2 of the nl2sol usage summary (which is an
!             appendix to ref. 1).
!
!  (selected) v output values
!
! v(dgnorm)... v(1) is the 2-norm of (d**-1)*g, where g is the most re-
!             cently computed gradient and d is the corresponding scale
!             vector.
! v(dstnrm)... v(2) is the 2-norm of d * step, where step is the most re-
!             cently computed step and d is the current scale vector.
! v(f)........ v(10) is the current function value (half the sum of
!             squares).
! v(f0)....... v(13) is the function value at the start of the current
!             iteration.
! v(nreduc)... v(6), if positive, is the maximum function reduction
!             possible according to the current model, i.e., the func-
!             tion reduction predicted for a Newton step (i.e.,
!             step = -h**-1 * g,  where  g = (j**t) * r  is the current
!             gradient and h is the current hessian approximation --
!             h = (j**t)*j  for the Gauss-Newton model and
!             h = (j**t)*j + s  for the augmented model).
!                  v(nreduc) = zero means h is not positive definite.
!                  if v(nreduc) is negative, then it is the negative of
!             the function reduction predicted for a step computed with
!             a step bound of v(lmax0) for use in testing for singular
!             convergence.
! v(preduc)... v(7) is the function reduction predicted (by the current
!             quadratic model) for the current step.  this (divided by
!             v(f0)) is used in testing for relative function
!             convergence.
! v(reldx).... v(17) is the scaled relative change in x caused by the
!             current step, computed as
!                  max(abs(d(i)*(x(i)-x0(i)), 1 <= i <= p) /
!                     max(d(i)*(abs(x(i))+abs(x0(i))), 1 <= i <= p),
!             where x = x0 + step.
!
  implicit none

  integer p

  external calcj
  external calcr
  integer, parameter :: d = 27
  integer d1
  integer iv(60+p)
  integer, parameter :: j = 33
  integer j1
  integer n
  integer nf
  integer, parameter :: nfcall = 6
  integer, parameter :: nfgcal = 7
  integer, parameter :: r = 50
  integer r1
  logical strted
  integer, parameter :: toobig = 2
  external ufparm
  integer uiparm(*)
  real urparm(*)
  real v(93 + n*p + 3*n + (p*(3*p+33))/2)
  real x(p)

  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) /= 0 .and. iv(1) /= 12 ) then
    go to 40
  end if

         strted = .false.
         iv(nfcall) = 1
         iv(nfgcal) = 1

 10   continue

      nf = iv(nfcall)

      call calcr ( n, p, x, nf, v(r1), uiparm, urparm, ufparm )

      if ( strted ) then

        if ( nf <= 0 ) then
          iv(toobig) = 1
        end if

        go to 40

      end if

      if ( nf <= 0 ) then
        iv(1) = 13
        call itsmry ( v(d1), iv, p, v, x )
        return
      end if

30    continue

      call calcj ( n, p, x, iv(nfgcal), v(j1), uiparm, urparm, ufparm )

      if ( iv(nfgcal) == 0 ) then
        iv(1) = 15
        call itsmry ( v(d1), iv, p, v, x )
        return
      end if

      strted = .true.

 40   continue

      call nl2itr ( v(d1), iv, v(j1), n, n, p, v(r1), v, x )

  if ( iv(1) == 2 ) then
    go to 30
  end if

  if ( iv(1) < 2 ) then
    go to 10
  end if

  return
end
subroutine nl2x ( )

!*****************************************************************************80
!
!! NL2X tests nl2sol and nl2sno on madsen example.
!
  implicit none

  real &
     urparm(1),v(147),x(2)
  integer &
     iv(62),uiparm(1)
!
!  external subroutines
  external madj,madr,nl2sno,nl2sol,ufparm
!
  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
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 )

!*****************************************************************************80
!
!! NLCMP computes statistics for the NLS family when weights are involved.
!
!  Discussion:
!
!    this routine computes various statistics and values returned
!    and/or printed by the nls family of routines when weights are
!    involved.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real cond
!        the condition number of d.
!     real d(n,npar)
!        the first derivative of the model (jacobian).
!     logical exact
!        an indicator value used to designate whether the fit
!        was exact to machine precision (true) or not (false).
!     real fac
!        a factor used to correct for zero weighted observations in
!        the variance covariance computation.
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an index variable.
!     integer idf
!        the degrees of freedom in the fit.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer iskull(10)
!        an error message indicator variable.
!     integer j
!        an index variable.
!     integer jk
!        the index of the (j,k)th element of the variance-covariance
!        matrix.
!     integer k
!        an index variable.
!     integer lvcvl
!        the dimension of vector vcvl.
!     integer lwt
!        the dimension of vector wt.
!     integer n
!        the number of observations.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     real pvt(n)
!        the predicted value based on the current parameter estimates.
!     real rd(n)
!        the diagonal elements of the r matrix of the q - r
!        factorization of d.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the residual standard deviation.
!     real rss
!        the residual sum of squares.
!     real rsshlf
!        half the residual sum of squares.
!     real rvar
!        the residual variance.
!     real sdpvt(n)
!        the standard deviations of the predicted values.
!     real sdrest(n)
!        the standardized residuals.
!     real sm
!        a variable used for summation.
!     real tj
!        ...
!     real vcvl(lvcvl)
!        the lower half of the variance-covariance matrix, stored
!        row wise.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real wti
!        the actual weight used for the ith observation.
!     real wtsum
!        the sum of the weights.
!     real y(n)
!        the dependent variable.
!     real yss
!        the sum of the squares about the mean y value.
!     real ywtsm
!        the sum of the values y(i)*wt(i), i=1,n.
!     real ywtysm
!        the sum of the values y(i)*wt(i)*wt(i), i=1,n.
!
  implicit none

  integer n
  integer npar

  real cond
  logical exact
  integer i
  integer idf
  integer ierr
  integer j
  integer jk
  integer k
  real rsd
  real rss
  real rsshlf
  real rvar
  logical weight
  real yss
  real ywtsm

  integer &
     lvcvl,lwt,nnzw,npare
!
!  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)
!
!
  real &
     fac,fplm,sm,tj,wti,wtsum,ywtysm

!
!  external subroutines
  external fitext
!
!  common blocks
  common /errchk/ierr

  fplm = huge ( fplm )
!
!     compute residuals
!
  res(1:n) = y(1:n) - pvt(1:n)
!
!     compute various statistics
!
  idf = nnzw - npare
  rss = 2.0e0*rsshlf

  if (idf >= 1) then
    rvar = rss / real ( idf )
  else
    rvar = 0.0E+00
  end if

  rsd = sqrt(rvar)
  ywtsm = 0.0e0
  ywtysm = 0.0e0
  wtsum = 0.0e0

  if ( .not. weight ) then
    ywtsm = sum ( y(1:n) )
    ywtysm = sum ( y(1:n)**2 )
    wtsum = real ( n )
  else
    ywtsm = dot_product ( wt(1:n), y(1:n) )
    ywtysm = dot_product ( wt(1:n), y(1:n)**2 )
    wtsum = sum ( wt(1:n) )
  end if

  yss = max(ywtysm-(ywtsm*ywtsm)/wtsum,0.0e0)

  call fitext(rss, yss, exact)

  if (rd(npare) /= 0.0e0) then
    cond = abs(rd(1)/rd(npare))
  else
    cond = fplm
  end if

  if (ierr /= 0) then
    return
  end if
!
!  correct for degrees of freedom if necessary because of zero
!  weighted observations.
!
  if ( n /= nnzw ) then
    fac = real ( n - npare )
    if (idf >= 1) then
      fac = fac / real ( idf )
    end if
    vcvl(1:lvcvl) = vcvl(1:lvcvl)*fac
  end if
!
!  if the residual sum of squares is identically zero, then
!  no further computations are necessary
!
  if ((idf <= 0) .or. exact) return
!
!  if the standard deviations of the predicted values and
!  standardized residuals are not saved or printed, then no
!  further computations are necessary.
!
!  compute the standard deviations of the predicted values (sdpvt)
!
  do i=1,n

     sm = 0.0e0
     do j=1,npare
        tj = 0.0e0
        do k=1,npare
           if (j >= k) then
              jk = j*(j-1)/2 + k
           else
              jk = k*(k-1)/2 + j
           end if
           tj = tj + vcvl(jk)*d(i,k)
        end do
           sm = sm + d(i,j)*tj
     end do
     if (sm<0.0e0) sm = 0.0e0
     sdpvt(i) = sqrt(sm)

     sdrest(i) = fplm
     wti = 1.0e0
     if (weight) wti = wt(i)
     if (wti /= 0.0e0) then

     if (rvar/wti-sm <= 0.0e0) then
       sdrest(i) = fplm
       iskull(1) = 1
       iskull(4) = 1
       ierr = 4
     else
       sdrest(i) = res(i)/sqrt(rvar/wti-sm)
     end if

    end if

  end do

  return
end
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 )

!*****************************************************************************80
!
!! NLCNTA: controlling routine for NLS regression with analytic derivatives.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  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
!
!  array arguments
  real &
     par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),vcv(*),wt(*), &
     xm(*),y(*)
  integer &
     ifixed(*)
  character &
     nmsub(6)*1
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     isubhd,ldsmin,lstp,ndigit,neta,nrow,ntau
  logical &
     aprxdv,hlfrpt,page,prtfxd,wide
!
!  local arrays
  real &
     stp(1)
  integer &
     iptout(5)
!
!  external functions
  integer &
     icnti
  external icnti
!
!  external subroutines
  external dckcnt,ldscmp,nlcnt,nldrva,nler,nlhdra,prtcnt,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer idrvck
!        the variable used to indicate whether the derivatives are
!        to be checked (idrvck = 1) or not (idrvck = 0).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer iptout(5)
!        the variable used to control printed output for each section.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ivcvop
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivcvop le 0 indicates the the default option will be used
!        ivcvop eq 1 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivcvop eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivcvop eq 3 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivcvop eq 4 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivcvop eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivcvop eq 6 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivcvop ge 7 indicates the default option will be used
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     integer neta
!        the number of accurate digits in the model results.
!     external nldrva
!        the name of the routine which calculates the derivatives.
!     external nlhdra
!        the name of the routine which produces the heading.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     integer nrow
!        the number of the row of the independent variable array at
!        which the derivative is to be checked.
!     integer ntau
!        the number of digits of agreement required between the
!        numerically approximated derivatives and the user supplied
!        drvitives.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real pv(lpv)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(lscale)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(1)
!        the dummy step size array.
!     real vcv(ivcv,npar)
!        the variance-covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
  hlfrpt = .false.
  aprxdv = .false.
  prtfxd = .true.
  stp(1) = 0.0e0
  lstp = 1
  neta = 0
  ntau = 0
  nrow = 0

  wide = .true.
  page = .false.

  ndigit = 5

  ierr = 0
  if ((ifixed(1) >= 0) .and. (npar >= 1)) then
     npare = icnti(ifixed,npar,0)
  else
     npare = npar
  end if

  call ldscmp(6, 0, 60+2*npar, 0, 0, 0, 's', &
              94+n*(3+npar)+npare*(3*npare+35)/2, ldsmin)

  call nler (nmsub, weight, wt, lwt, n, m, ixm, &
     ifixed, lifixd, npar, npare, &
     ldstak, ldsmin, stp, lstp, scale, lscale, ivcv, save, nnzw)

  if (ierr /= 0) return

  call stkset(ldstak, 4)
!
!  set print control values
!
  call prtcnt(nprt, ndigit, iptout)
!
!  check derivatives, if desired
!
  if ( idrvck /= 0 ) then

    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)

    if ( 3 <= ierr ) then
      ierr = 1
      return
    end if

  end if

  ierr = 0

  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)

  return
end
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 )

!*****************************************************************************80
!
!! NLCNT controlling subroutine for nonlinear least squares regression.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     integer d
!        the starting location in rstak/dstak of
!        the array in which the numerical derivatives with respect to
!        each parameter are stored.
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd
!        the starting location in istak of
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer iiwork
!        the dimension of the integer work vector iwork.
!     integer iptout(5)
!        the variable used to control printed output for each section.
!     integer irwork
!        the dimension of the real work vector rwork.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer iwork
!        the starting location in istak of
!        the integer work space vector used by the nl2 subroutines.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lvcvl
!        the length of the vector containing
!        the lower half of the vcv matrix, stored row wise.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.
!     integer n
!        the number of observations.
!     integer nall0
!        number of allocations on entry.
!     integer ndigit
!        the number of digits in the print control value.
!     external nldrv
!        the name of the routine which calculates the derivatives.
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     integer pare
!        the starting location in rstak/dstak of
!        the current estimates of the parameters, but only
!        those to be optimized (not those whose values are fixed).
!     real pv(lpv)
!        the predicted value based on the current parameter estimates
!     integer pvi
!        the starting location in rstak/dstak of
!        the predicted values.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer rwork
!        the starting location in rstak/dstak of
!        the real work vector used by the nl2 subroutines.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(lscale)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     integer sdpvi
!        the starting location in rwork of
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     integer sdresi
!        the starting location in rwork of the
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(lstp)
!        the step size array.
!     real vcv(ivcv,npar)
!        the variance-covariance matrix.
!     integer vcvl
!        the starting location in rwork of
!        the variance-covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
  implicit none

  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
!
!  array arguments
  real &
     par(*),pv(lpv),res(*),scale(*),sdpv(lsdpv),sdres(lsdres),stp(*),vcv(*), &
     wt(*),xm(*),y(*)
  integer &
     ifixed(lifixd),iptout(5)
!
!  subroutine arguments
  external drv,mdl,nldrv,nlhdr
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     d,ifixd,ifp,iiwork,irwork,iwork,lvcvl,nall0,pare,pvi, &
     rwork,sdpvi,sdresi,vcvl
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external cpyasf,cpyvii,nlmn,scopy,setiv,stkclr
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))

  nall0 = stkst(1)

  ifp = 3

  ierr = 0
!
!  subdivide work area for least squares analysis
!
  iiwork = npare + 60
  irwork = 94 + 2*n + npare*(3*npare+33)/2

  ifixd = stkget(npar,2)
  iwork = stkget(iiwork,2)

  d = stkget(n*npar,ifp)
  pare = stkget(npare,ifp)
  pvi = stkget(n,ifp)
  rwork = stkget(irwork,ifp)

  if (ierr == 1) return
!
!  set values for ifixd
!
  if (ifixed(1) >= 0) call cpyvii(npar, ifixed, 1, istak(ifixd), 1)
  if (ifixed(1)<0) call setiv(istak(ifixd), npar, 0)

  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)

  if ( save ) then

    sdpvi = rwork + sdpvi - 1
    sdresi = rwork + sdresi - 1
    vcvl = rwork + vcvl - 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 cpyasf(npare, rstak(vcvl), lvcvl, vcv, ivcv)

  end if

  call stkclr(nall0)

  return
end
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 )

!*****************************************************************************80
!
!! NLCNTN controlling routine for NLS regression with approximate derivatives.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  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
!
!  array arguments
  real &
     par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), &
     wt(*),xm(*),y(*)
  integer &
     ifixed(*)
  character &
     nmsub(6)*1
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     exmpt
  integer &
     ifp,is,isubhd,ldsmin,nall0,ndigit,neta,stpi
  logical &
     aprxdv,hlfrpt,page,prtfxd,wide
!
!  local arrays
  real &
     rstak(12)
  integer &
     iptout(5),istak(12)
!
!  external functions
  integer &
     icnti,stkget,stkst
  external icnti,stkget,stkst
!
!  external subroutines
  external drv,ldscmp,nlcnt,nldrvn,nler,nlhdrn,prtcnt,scopy,stkclr, &
     stkset,stpcnt
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!     variable definitions (alphabetically)
!
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real exmpt
!        the proportion of observations for which the computed
!        numerical derivatives wrt a given parameter are exempted
!        from meeting the derivative acceptance criteria.
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer iptout(5)
!        the variable used to control printed output for each section.
!     integer is
!        a value used to determine the amount of work space needed
!        based on whether step sizes are input or are to be calculated.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isubhd
!        an integer value specifying subheadings to be printed.
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ivcvop
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivcvop le 0 indicates the the default option will be used
!        ivcvop eq 1 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivcvop eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivcvop eq 3 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivcvop eq 4 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivcvop eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivcvop eq 6 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivcvop ge 7 indicates the default option will be used
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.
!     integer n
!        the number of observations.
!     integer nall0
!        number of allocations on entry.
!     integer ndigit
!        the number of digits in the print control value.
!     integer neta
!        the number of accurate digits in the model results.
!     external nldrvn
!        the name of the routine which calculates the derivatives.
!     external nlhdrn
!        the name of the routine which produces the heading.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real pv(lpv)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(lscale)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(lsdpv)
!        the standard deviations of the predicted values.
!     real sdres(lsdres)
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(lstp)
!        the step size array.
!     integer stpi
!        the starting location in rstak/dstak of
!        the step size array.
!     real vcv(ivcv,npar)
!        the variance-covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
  hlfrpt = .false.
  aprxdv = .true.
  prtfxd = .true.
  exmpt = -1.0e0
  neta = 0

  wide = .true.
  page = .false.

  ndigit = 5

  ierr = 0
  if ((ifixed(1) >= 0) .and. (npar >= 1)) then
     npare = icnti(ifixed,npar,0)
  else
     npare = npar
  end if

  if (stp(1) <= 0.0e0) then
     is = 1
  else
     is = 0
  end if

  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)

  call nler (nmsub, weight, wt, lwt, n, m, ixm, &
     ifixed, lifixd, npar, npare, &
     ldstak, ldsmin, stp, lstp, scale, lscale, ivcv, save, nnzw)

  if (ierr /= 0) return

  call stkset(ldstak, 4)
!
!  set print control values
!
  call prtcnt(nprt, ndigit, iptout)
!
!  subdivide workspace for step sizes
!
  nall0 = stkst(1)

  ifp = 3

  stpi = stkget(npar,ifp)
!
!  copy supplied step sizes to work space
!
  call scopy(lstp, stp, 1, rstak(stpi), 1)

  if (ierr == 0) then
!
!  select step sizes, if desired
!
    isubhd = 1

    if (stp(1) <= 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)

    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)

  end if

  call stkclr(nall0)

  return
end
subroutine nldrva ( mdl, drv, done, ifixd, par, npar, xm, n, m, &
     ixm, pv, d, weight, wt, lwt, stp, lstp, scl, lscl )

!*****************************************************************************80
!
!! NLDRVA computes the analytic derivative matrix from the user DERIV routine.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,lscl,lstp,lwt,m,n,npar
  logical &
     done,weight
!
!  array arguments
  real &
     d(n,npar),par(npar),pv(n),scl(lscl),stp(lstp),wt(lwt), &
     xm(ixm,m)
  integer &
     ifixd(npar)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     wtsqrt
  integer &
     i,j,jpk
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real d(n,npar)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     logical done
!        the variable used to indicate whether this is the final
!        computation of the jacobian or not.
!     integer i
!        an indexing variable.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the parameter being examined.
!     integer jpk
!        the index of the packed parameters.
!     integer lscl
!        the actual length of the vector scl.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer npar
!        the number of parameters in the model.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(n)
!        the predicted values based on the current parameter estimates
!     real scl(lscl)
!        the scale values.
!     real stp(lstp)
!        the selected relative step sizes.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real wtsqrt
!        the square root of the ith weight.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
!  compute jacobian
!
  call drv(par, npar, xm, n, m, ixm, d)

  jpk = 0

  do j=1,npar
     if (ifixd(j) /= 0) then
       cycle
     end if
     jpk = jpk + 1
     do i=1,n
        wtsqrt = 1.0e0
        if (weight .and. (.not.done)) wtsqrt = sqrt(wt(i))
        d(i,jpk) = -wtsqrt*d(i,j)
     end do
  end do

  return
end
subroutine nldrvn ( mdl, drv, done, ifixd, par, npar, xm, n, m, &
     ixm, pvt, d, weight, wt, lwt, stpt, lstpt, scl, lscl )

!*****************************************************************************80
!
!! NLDRVN approximates the derivative matrix.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,lscl,lstpt,lwt,m,n,npar
  logical &
     done,weight
!
!  array arguments
  real &
     d(n,npar),par(npar),pvt(n),scl(lscl),stpt(lstpt),wt(lwt), &
     xm(ixm,m)
  integer &
     ifixd(npar)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     pj,stpj,wtsqrt
  integer &
     i,j,jpk
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real d(n,npar)
!        the first derivative of the model (jacobian).
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     logical done
!        the variable used to indicate whether this is the final
!        computation of the jacobian or not.
!     integer i
!        an index variable.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer ixm
!        the first dimension of matrix xm.
!     integer j
!        an index variable.
!     integer jpk
!        an index variable.
!     integer lscl
!        the dimension of vector scl.
!     integer lstpt
!        the dimension of vector stpt.
!     integer lwt
!        the dimension of vector wt.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer npar
!        the number of parameters in the model.
!     real par(npar)
!        the current estimates of the parameters.
!     real pj
!        a temporary location for storage of the jth parameter.
!     real pvt(n)
!        the predicted value based on the current parameter estimates.
!     real scl(lscl)
!        the scale values.
!     real stpt(lstpt)
!        the step size array.
!     real stpj
!        the jth step size.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real wtsqrt
!        the square root of the user supplied weights.
!     real xm(ixm,m)
!        the independent variable.
!
!  compute finite-difference jacobian of the optimized parameters
!
  jpk = 0

  do j=1,npar

     if (ifixd(j) == 0) then
        jpk = jpk + 1
        pj = par(j)
        if (scl(jpk) == 0.0e0) then
           if (par(j) /= 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

        stpj = stpj + par(j)
        stpj = stpj - par(j)

        par(j) = pj + stpj
        call mdl(par, npar, xm, n, m, ixm, d(1,j))

        do 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
        end do

        par(j) = pj
     end if
  end do

  return
end
subroutine nler ( nmsub, weight, wt, lwt, n, m, ixm, ifixed, lifixd, npar, &
  npare, ldstak, ldsmin, stp, lstp, scale, lscale, ivcv, save, nnzw )

!*****************************************************************************80
!
!! NLER does error checking routine for nonlinear least squares estimation.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ivcv,ixm,ldsmin,ldstak,lifixd,lscale,lstp,lwt,m,n,nnzw, &
     npar,npare
  logical &
     save,weight
!
!  array arguments
  real &
     scale(*),stp(*),wt(*)
  integer &
     ifixed(lifixd)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,nfix,nnfix,nv,nzw
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,eiveq,ervgt,ervwt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical error(20)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1
!    +   lifix(8), livcv(8), lixm(8), llds(8), lm(8), ln(8), lnpar(8),
!    +   lnpare(8), lone(8), lscl(8), lstep(8), lwgt(8), lzero(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer lscale
!        the actual length of the vector scale.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer nzw
!        the number of zero weights.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(lscale)
!        the typical size of the parameters.
!     real stp(lstp)
!        the step size array.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!
!
!     set up name arrays
!
  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',' ',' ',' ',' '/

  error(1:20) = .false.

  ierr = 0
  head = .true.
  nnzw = n

  call eisge(nmsub, lnpar, npar, 1, 2, head, error(1), lone)
  if (error(1)) then
    error(7) = .true.
  else
    if (ifixed(1)<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

  call eisge(nmsub, lm, m, 1, 2, head, error(4), lone)

  if (.not.error(7)) &
     call eisge(nmsub, lixm, ixm, n, 3, head, error(5), ln)

  if (.not.error(1)) then
     if ((.not.error(2)) .and. (.not.error(7))) &
        call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(6), &
        llds)

     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) &
        call eisge(nmsub, livcv, ivcv, npare, 3, head, error(15), &
        lnpare)
  end if

  do i=1,20
     if ( error(i) ) then
       ierr = 1
       return
     end if
  end do

  return
end
subroutine nlerr ( icnvcd, iskull )

!*****************************************************************************80
!
!! NLERR sets the error flag ierr based on the convergence code returned by NL2.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index variable.
!     integer icnvcd
!        the convergence code from nl2.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer iskull(10)
!        an error message indicator variable.
!
  implicit none

  integer &
     icnvcd
!
!  array arguments
  integer &
     iskull(10)
!
!  scalars in common
  integer &
     ierr
!
!  common blocks
  common /errchk/ierr
!
!     initialize message indicator variable
!
  iskull(1:10) = 0
!
!  set error flag
!
  go to (10, 10, 20, 20, 20, 20, 40, 50, 60, 60, 10, 30, 10, 10, &
     10), icnvcd
!
!     bad value
!
   10 ierr = 1
  return
!
!  acceptable stopping condition
!
   20 ierr = 0
  return
!
!  initial variance computation overflows
!
   30 ierr = 2
  iskull(2) = 1
  return
!
!  singular convergence
!
   40 ierr = 3
  iskull(3) = 1
  return
!
!  false convergence
!
   50 ierr = 5
  iskull(5) = 1
  return
!
!  iteration or function evaluation limit
!
   60 ierr = 6
  iskull(6) = 1
  return
end
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 )

!*****************************************************************************80
!
!! NLFIN completes the NLS analysis once the estimates have been found.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
  implicit none

  real &
     rsd,rsshlf
  integer &
     ivcvpt,ixm,lvcvl,lwt,m,n,ndigit,nnzw,npar,npare
  logical &
     page,weight,wide
!
!  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)
!
!  subroutine arguments
  external nlhdr
!
!  scalars in common
  integer &
     ierr

  real &
     cond,rss,yss
  integer &
     idf
  logical &
     exact,prtfsm
!
!  external subroutines
  external nlcmp,nlout
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real cond
!        the condition number of d.
!     real d(n,npar)
!        the derivative of the model (jacobian).
!     logical exact
!        an indicator value used to designate whether the fit
!        was exact to machine precision (true) or not (false).
!     integer idf
!        the degrees of freedom in the fit.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) have been held fixed.
!        if ifixed(i) == 0, then par(i) have been optimized.
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer iskull(10)
!        an error message indicator variable.
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!     integer ixm
!        the first dimension of the independent variable array.
!     integer lvcvl
!        the length of the vector containing
!        the lower half of the vcv matrix, stored row wise.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     real par(npar)
!        the array in which the current estimates of the
!        parameters are stored.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical prtfsm
!        the variable used to indicate whether any of the summary
!        information is to be printed (true) or not (false).
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real rd(npare)
!        the diagonal elements of the r matrix of the q - r
!        factorization of d.
!     real res(n)
!        the residuals from the fit.
!     real rsshlf
!        half the residual sum of squares.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     real rss
!        the residual sum of squares.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     real vcvl(lvcvl)
!        the lower half of the vcv matrix, stored row wise.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!     real yss
!        the sum of squares of the dependent variable y.
!
!
!  compute returned and/or printed values.
!
  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)

  prtfsm = ((iptout(3) /= 0) .or. (iptout(4) /= 0) .or. &
     (iptout(5) /= 0) .or. (ierr /= 0))
!
!  print summary information if desired or if an error flag
!  has been set.
!
  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
end
subroutine nlhdra ( page, wide, isubhd )

!*****************************************************************************80
!
!! NLHDRA prints headings for NLS estimation using analytic derivatives.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide
!
!
!  external subroutines
  external versp
!
!     variable definitions (alphabetically)
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  if (page) write ( *, 1020)
  call versp(wide)
  if (page) write ( *,1000)
  if (.not.page) write ( *,1010)
  page = .true.

  if (isubhd == 0) return

  write ( *, 1030)

  return

 1000 format ('+nonlinear least squares estimation', &
     ' with user-supplied derivatives, continued')
 1010 format ('+', 71('*')/ &
     1x, '*  nonlinear least squares estimation', &
     ' with user-supplied derivatives  *'/ 1x, 71('*'))
 1020 format ('1')
 1030 format (//' summary of initial conditions'/ 1x, 30('-'))
end
subroutine nlhdrn ( page, wide, isubhd )

!*****************************************************************************80
!
!! NLHDRN prints headings for NLS estimation using approximate derivatives.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide
!
!
!  external subroutines
  external versp
!
!     variable definitions (alphabetically)
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  if (page) write ( *, 1020)
  call versp(wide)
  if (page) write ( *,1000)
  if (.not.page) write ( *,1010)
  page = .true.

  if (isubhd == 0) return

  write ( *, 1030)

  return

 1000 format ('+nonlinear least squares estimation', &
     ' with numerically approximated derivatives, continued')
 1010 format ('+', 82('*')/ &
     1x, '*  nonlinear least squares estimation', &
     ' with numerically approximated derivatives  *'/ 1x, 82('*'))
 1020 format ('1')
 1030 format (//' summary of initial conditions'/ 1x, 30('-'))
end
subroutine nlinit ( n, ifixd, par, npar, pare, npare, mit, &
  stopss, stopp, scale, lscale, delta, ivaprx, aprxdv, ivcvpt, &
  iwork, iiwork, rwork, irwork, scl )

!*****************************************************************************80
!
!! NLINIT initializes the NLS routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
  implicit none

  real &
     delta,stopp,stopss
  integer &
     iiwork,irwork,ivaprx,ivcvpt,lscale,mit,n,npar,npare,scl
  logical &
     aprxdv
!
!  array arguments
  real &
     par(npar),pare(npar),rwork(irwork),scale(lscale)
  integer &
     ifixd(npar),iwork(iiwork)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     afctol,cnvcod,covprt,covreq,dinit,dtype,iscl,j,lmax0, &
     mxfcal,mxiter,niter,outlev,prunit,rfctol,sclj,solprt, &
     statpr,x0prt,xctol
!
!  external functions
  real &
     rmdcon
  external rmdcon
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer afctol
!        the location in rwork of the absolute convergence tolerance.
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     integer cnvcod
!        a value used to control the printing of iteration reports.
!     integer covprt
!        the location in iwork of the variable used to indicate whether
!        the covariance matrix is to be printed by the nl2 code, where
!        iwork(covprt) = 0 indicates it is not.
!     integer covreq
!        the location in iwork of the variable used to indicate how
!        the covariance matrix is to be computed by the nl2 code, where
!        iwork(covreq) = 3 indicates the covariance matrix is to be comp
!        as the residual variance times the inverse of the jacobian matr
!        transposed times the jacobian matrix .
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     integer dinit
!        the location in iwork of the value used to indicate
!        whether or not user supplied scale values are to be
!        used, where the (nl2) default value of rwork(dinit) = 0.0e0
!        inidcates no, and the value rwork(dinit) = -1.0e0 indicates
!        yes.
!     integer dtype
!        the location in iwork of the value indicating whether the
!        scale values have been supplied by the user (iwork(dtype)  <=
!        or the default values are to be used (iwork(dtype) > 0).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer iiwork
!        the dimension of the integer work vector iwork.
!     integer irwork
!        the dimension of the real work vector rwork.
!     integer iscl
!        the location in iwork indicating the starting location in
!         rwork of the scale vector.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!     integer iwork(iiwork)
!        the integer work space vector used by the nl2 subroutines.
!     integer j
!        the index of the parameter being examined.
!     integer lmax0
!        the location in rwork of the value indicating the
!        maximum change allowed in the model parameters at the
!        first iteration.
!     integer mit
!        the maximum number of iterations allowed.
!     integer mxfcal
!        the location in iwork of the variable designating the
!        maximum number of function calls allowed, excluding
!        calls necessary to compute the derivatives and variance
!        covariance matrix.
!     integer mxiter
!        the location in iwork of the variable designating the
!        maximum number of iterations allowed.
!     integer n
!        the number of observations.
!     integer niter
!        the location in iwork of the number of the current iteration.
!     integer npar
!        the number of unknown parameters in the model.
!     integer npare
!        the number of unknown parameters to be optimized.
!     integer outlev
!        the location in iwork of the parameter used to control the
!        printing of the iteration reports by nl2.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real pare(npar)
!        the current estimates of the unknown parameters, but only
!        those to be optimized (not those whose values are fixed).
!     integer prunit
!        the location in iwork of the parameter used to control
!        the print unit used by nl2.  iwork(prunit) = 0 means
!        dont print anything.
!     integer rfctol
!        the location in rwork of the relative function convergence
!        tolerance.
!     real rwork(irwork)
!        the real work vector used by the nl2 subroutines.
!     real scale(lscale)
!        the typical size of the unknown parameters.
!     integer scl
!        the index in rwork of the 1st value of the user supplied scale
!        value.
!     integer sclj
!        the index in rwork of the jth value of the user supplied scale
!        value.
!     integer solprt
!        the location in iwork of the parameter used to control printing
!        by nl2 of the final solution.
!     integer statpr
!        the location in iwork of the parameter used to control printing
!        by nl2 of summary statistics.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     integer xctol
!        the location in rstak/dstak of the p convergence tolerance.
!     integer x0prt
!         the location in iwork of the parameter used to control printin
!        by nl2 of the initial parameter and scale values.
!
!  iwork subscript values
!
  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/
!
!  rwork subscript values
!
  data afctol /31/, lmax0 /35/, rfctol /32/, xctol /33/
!
!  pack parameters into pare
!
  call nlspk(par, ifixd, npar, pare, npar)
!
!  set nl2sol default values
!
  call dfault(iwork, rwork)
!
!  set non nl2 default values
!
  iwork(mxiter) = mit
  if (mit <= 0) iwork(mxiter) = 21

  iwork(mxfcal) = 2*iwork(mxiter)
!
!  set stopping criterion
!
  rwork(afctol) = rmdcon(1)

  if ( stopss  >=  epsilon ( stopss ) .and. stopss <= 0.1 ) then
    rwork(rfctol) = stopss
  end if

  if ((stopp >= 0.0e0) .and. (stopp <= 1.0e0)) &
     rwork(xctol) = stopp
!
!  set scale values
!
  scl = 94 + 2*n + npare*(3*npare+31)/2
  iwork(iscl) = scl

  if ( scale(1) <= 0.0e0 ) then

    iwork(dtype) = 1
!
!  initialize scale values for first iteration
!
    sclj = scl - 1
    do j=1,npar
      if (ifixd(j) == 0) then
        sclj = sclj + 1
        if (par(j) == 0.0e0) rwork(sclj) = 1.0e0
        if (par(j) /= 0.0e0) rwork(sclj) = 1.0e0/abs(par(j))
      end if
    end do

  else

    iwork(dtype) = 0
    rwork(dinit) = -1.0e0
    sclj = scl - 1
    do j=1,npar
       if ( ifixd(j) == 0) then
        sclj = sclj + 1
        rwork(sclj) = 1.0e0/max(abs(scale(j)),abs(par(j)))
      end if
    end do

  end if

  if (delta <= 0.0e0) then
    rwork(lmax0) = 100.0e0
  else
    rwork(lmax0) = delta
  end if
!
!  set nl2 covariance computation control parameter
!
  if ((ivaprx <= 1) .or. (ivaprx == 4) .or. (ivaprx >= 7)) &
     iwork(covreq) = 3
  if ((ivaprx == 2) .or. (ivaprx == 5)) iwork(covreq) = 2
  if ((ivaprx == 3) .or. (ivaprx == 6)) iwork(covreq) = 1
  if ((ivaprx >= 4) .and. (ivaprx <= 6)) &
     iwork(covreq) = -iwork(covreq)
  if (aprxdv) iwork(covreq) = -iabs(iwork(covreq))
  if ((ivaprx <= 1) .or. (ivaprx == 4) .or. (ivaprx >= 7)) &
     ivcvpt = 1
  if ((ivaprx == 2) .or. (ivaprx == 5)) ivcvpt = 2
  if ((ivaprx == 3) .or. (ivaprx == 6)) ivcvpt = 3
!
!  initialize the iteration counter
!
  iwork(niter) = 0
!
!  set nl2 print control parameters
!
  iwork(cnvcod) = 0
  iwork(covprt) = 0
  iwork(outlev) = 0
  iwork(prunit) = 0
  iwork(solprt) = 0
  iwork(statpr) = 0
  iwork(x0prt) = 0

  return
end
subroutine nlism ( nlhdr, page, wide, hlfrpt, npar, m, n, nnzw, &
  weight, ifixd, par, scale, iwork, iiwork, rwork, irwork, res, &
  aprxdv, stp, lstp, npare )

!*****************************************************************************80
!
!! NLISM prints an initial summary for the nonlinear least squares routines.
!
!  Discussion:
!
!    This routine prints an initial summary of the starting
!    estimates and the control parameters for the nonlinear
!    least squares subroutines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iiwork,irwork,lstp,m,n,nnzw,npar,npare
  logical &
     aprxdv,hlfrpt,page,weight,wide
!
!  array arguments
  real &
     par(npar),res(n),rwork(irwork),scale(npar),stp(lstp)
  integer &
     ifixd(npar),iwork(iiwork)
!
!  subroutine arguments
  external nlhdr

  real &
     rsd,rss
  integer &
     i,isubhd,lmax0,mxfcal,mxiter,rfctol,xctol
!
!  external functions
  real &
     snrm2
  external snrm2
!
!     variable definitions (alphabetically)
!
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer i
!        an index variable
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer iiwork
!        the dimension of the integer work vector iwork.
!     integer irwork
!        the dimension of the real work vector rwork.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer iwork(iiwork)
!        the integer work space vector used by the nl2 subroutines.
!     integer lmax0
!        the location in rwork of the value indicating the
!        maximum change allowed in the model parameters at the
!        first iteration.
!     integer lstp
!        the actual length of the vector stp.
!     integer m
!        the number of independent variables.
!     integer mxfcal
!        the location in iwork of the variable designating the
!        maximum number of function calls allowed, excluding
!        calls necessary to compute the derivatives and covariance
!        matrix.
!     integer mxiter
!        the location in iwork of the variable designating the
!        maximum number of iterations allowed.
!     integer n
!        the number of observations.
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of unknown parameters in the model.
!     integer npare
!        number of parameters estimated by routine.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real res(n)
!        the residuals from the fit.
!     integer rfctol
!        the location in rwork of the relative function convergence
!        tolerance.
!     real rsd
!        the residual standard deviation at the initial parameter values
!     real rss
!        the residual sum of squares at the initial parameter values
!     real rwork(irwork)
!        the real work vector used by the nl2 subroutines.
!     real scale(npar)
!        the typical size of the unknown parameters.
!     real stp(lstp)
!        the selected relative step sizes.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!       the variable used to indicate whether the heading should
!        full width (true) or not (false).
!     integer xctol
!        the location in rstak/dstak of the p convergence tolerance.
!
!  iwork subscript values
!
  data mxfcal/17/, mxiter/18/
!
!  rwork subscript values
!
  data lmax0/35/, rfctol/32/, xctol/33/

  if (.not.hlfrpt) then

     isubhd = 1
     call nlhdr(page, wide, isubhd)

     if (aprxdv) then
        write ( *, 1260)
     else
        write ( *, 1270)
     end if

     do i = 1, npar
        if (ifixd(i) == 0) then
           if (scale(1) > 0.0e0) then
              if (aprxdv) then
                 write ( *, 1410) i, par(i), scale(i), stp(i)
              else
                 write ( *, 1410) i, par(i), scale(i)
              end if
           else
              if (aprxdv) then
                 write ( *, 1310) i, par(i), stp(i)
              else
                 write ( *, 1310) i, par(i)
              end if
           end if
        else
           if (aprxdv) then
              write ( *, 1510) i, par(i)
           else
              write ( *, 1610) i, par(i)
           end if
        end if
     end do

     write ( *, 1160) n

  end if

  if (weight) write ( *, 1170) nnzw
  write ( *, 1180) m
  write ( *, 1070) iwork(mxiter)
  write ( *, 1090) iwork(mxfcal)
  write ( *, 1080)
  write ( *, 1100) rwork(rfctol)
  write ( *, 1110) rwork(xctol)
  write ( *, 1120) rwork(lmax0)

  rsd = snrm2(n, res, 1)
  rss = rsd * rsd
  if (nnzw-npare >= 1) rsd = rsd /sqrt(real(nnzw-npare))
  write ( *, 1200) rss
  write ( *, 1210) rsd

  return

 1070 format (/' maximum number of iterations allowed', 32x, '(mit)', &
     1x, i5)
 1080 format(/' convergence criterion for test based on the'/)
 1090 format(/' maximum number of model subroutine calls', &
     ' allowed', 26x, i5)
 1100 format (5x, ' forecasted relative change in residual', &
     ' sum of squares', 7x, '(stopss)', 1x, g11.4)
 1110 format(5x, ' maximum scaled relative change in the parameters', &
     13x, '(stopp)', 1x, g11.4)
 1120 format(//' maximum change allowed in the parameters', &
     ' at the first iteration', 3x, '(delta)', 1x, g11.4)
 1160 format (/' number of observations', 48x, '(n)', 1x, i5)
 1170 format (/' number of non zero weighted observations', 27x, &
     '(nnzw)', 1x, i5)
 1180 format (/' number of independent variables', 39x, '(m)', 1x, i5)
 1200 format (/' residual sum of squares for input parameter', &
     ' values', 24x, g11.4)
 1210 format (/' residual standard deviation for input parameter', &
     ' values', 14x, '(rsd)', 1x, g11.4)
 1260 format (//50x, 'step size for'/ &
     50x, 'approximating'/ &
     7x, 'parameter starting value', 6x, 'scale', 10x, &
     'derivative'/ &
     1x, 'index', 2x, 'fixed', 6x, '(par)', 12x, '(scale)', 11x, &
     '(stp)'/)
 1270 format (//6x, 'parameter starting values', 5x, 'scale'/ &
     1x, 'index', 2x, 'fixed', 6x, '(par)', 11x, '(scale)'/)
 1310 format (1x, i3, 5x, ' no', g17.8, 7x, 'default', 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
subroutine nlitrp ( nlhdr, head, page, wide, iptout, npar, nnzw, &
  iwork, iiwork, rwork, irwork, ifixd, pare, npare )

!*****************************************************************************80
!
!! NLITRP prints iteration reports for nonlinear least squares regression.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iiwork,iptout,irwork,nnzw,npar,npare
  logical &
     head,page,wide
!
!  array arguments
  real &
     pare(npar),rwork(irwork)
  integer &
     ifixd(npar),iwork(iiwork)
!
!  subroutine arguments
  external nlhdr
!
!
  real &
     rsd,rss,rssc,rsspc
  integer &
     dst0,f,f0,fdif,isubhd,mxiter,nfcall,niter, &
     nreduc,preduc,reldx,stppar
  character &
     lettrn*1,lettry*1
!
!  local arrays
  character &
     ischkd(2)*1
!
!  external subroutines
  external lstvcf
!
!     variable definitions (alphabetically)
!
!     integer dst0
!        the location in rwork of the value of the 2 norm of d times
!        the  newton step.
!     integer f
!        the location in rwork of the value of half the residual
!        sum of squares at the current parameter values.
!     integer fdif
!        the location in rwork of the difference between the
!        residual sum of squares at the beginning and end of the
!        current iteration.
!     integer f0
!        the location in rwork of the value of half the residual
!        variance at the beginning of the current iteration.
!     logical head
!        the variable used to indicate whether a heading is to be
!        printed during a given call to the iteration report (true)
!        or not (false).
!     integer icase
!        an indicater variable used to designate the message to be
!        printed.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer iiwork
!        the dimension of the integer work vector iwork.
!     integer irwork
!        the dimension of the real work vector rwork.
!     character*1 ischkd(2)
!        the indicator used to designate whether the
!        test value was checked for convergence (y) or not (n).
!     integer isubhd
!        an integer value specifying subheadings to be printed.
!     integer iwork(iiwork)
!        the integer work space vector used by the nl2 subroutines.
!     character*1 lettrn, lettry
!        the letters n and y, respectively.
!     integer mxiter
!        the location in iwork of the variable designating the
!        maximum number of iterations allowed.
!     integer nfcall
!        the location in iwork of the number of function evaluations.
!     integer niter
!        the location in iwork of the number of the current iteration.
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer npar
!        the number of unknown parameters in the model.
!     integer npare
!        the number of unknown parameters to be optimized.
!     integer nnzw
!        the number of non zero weights.
!     integer nreduc
!        the location in rwork of the value used to check if the
!        hessian approximation is positive definite.  if
!        if rwork(nreduc) == 0, the hessian is singular, otherwise
!        it is not.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real pare(npar)
!        the current estimates of the unknown parameters, but only
!        those to be optimized (not those whose values are fixed).
!     integer preduc
!        the location in rwork of the predicted function reduction
!        for the current step.
!     integer reldx
!        the location in rwork of the scaled relative change in
!        the parameter values caused by the current iteration.
!     real rsd
!        the residual standard deviation.
!     real rss
!        the residual sum of squares.
!     real rssc
!        the change in the residual sum of squares caused by this
!        iteration.
!     real rsspc
!        the predicted change in the residual sum of squares at this
!        iteration.
!     real rwork(irwork)
!        the real work vector used by the nl2 subroutines.
!     integer stppar
!        the location in rwork of the marquardt lambda parameter.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  data lettrn /'n'/, lettry /'y'/
!
!  iwork subscript values
!
  data mxiter /18/, nfcall /6/, niter /31/
!
!  rwork subscript values
!
  data dst0 /3/, f /10/, fdif /11/, f0 /13/, nreduc /6/, preduc &
     /7/, reldx /17/, stppar /5/

  if (iwork(1) == 10) then
    write ( *,1100)
    return
  end if

  if ((iptout == 1) .and. (iwork(niter) /= 1) .and. &
     (iwork(niter) /= iwork(mxiter)) .and. (iwork(1) <= 2)) return

  isubhd = 0
  if (head) call nlhdr(page, wide, isubhd)
  head = .false.
  if (mod(iwork(niter),4) == 0) head = .true.

  write ( *,1000) iwork(niter)
!
!  compute statistics to be printed
!
  rss = 2.0e0*rwork(f)
  rsd = sqrt(rss)
  if (nnzw-npare >= 1) rsd = rsd/sqrt(real(nnzw-npare))

  rssc = 0.0e0
  if (rwork(f0) > 0.0e0) rssc = rwork(fdif)/rwork(f0)

  rsspc = 0.0e0
  if (rwork(f0) > 0.0e0) rsspc = rwork(nreduc)/rwork(f0)
!
!  reference nl2 subroutine assess, statement label 300 to 320
!
  ischkd(1) = lettrn
  ischkd(2) = lettrn

  if ( rwork(fdif) <= 2.0e0*rwork(preduc) ) then

    if ( 0.0 <= rwork(dst0) ) then
      if (rwork(nreduc) >= 0.0e0) ischkd(1) = lettry
      if (rwork(stppar) == 0.0e0) ischkd(2) = lettry
    end if

  end if

  write ( *,1010) iwork(nfcall), rsd, rss, rssc, rsspc, &
     ischkd(1), rwork(reldx), ischkd(2)
  if (npare<npar) write ( *,1020)
  if (npare >= npar) write ( *,1150)
  call lstvcf(npare, pare, npar, ifixd)
!
!  print final iteration message
!
  if ( iwork(1) == 3 ) then
    write ( *,1030)
  else if ( iwork(1) == 4 ) then
    write ( *,1040)
  else if ( iwork(1) == 5 ) then
    write ( *,1050)
  else if ( iwork(1) == 6 ) then
    write ( *,1060)
  else if ( iwork(1) == 7 ) then
    write ( *,1070)
  else if ( iwork(1) == 8 ) then
    write ( *,1080)
  else if ( iwork(1) == 9 ) then
    write ( *,1090)
  else if ( iwork(1) == 10 ) then
    write ( *,1100)
  else if ( iwork(1) == 11 ) then
    write ( *,1110)
  else if ( iwork(1) == 12 ) then
    write ( *,1120)
  else if ( iwork(1) == 13 ) then
    write ( *,1130)
  else if ( iwork(1) == 14 ) then
    write ( *,1140)
  end if

  return

 1000 format (//' iteration number', i5/1x, 22('-'))
 1010 format (5x, 'model', 53x, 'forecasted'/5x, 'calls', 9x, 'rsd', &
     13x, 'rss', 8x, 'rel chng rss', 4x, 'rel chng rss', 4x, &
     'rel chng par'/62x, 'value', 3x, 'chkd', 4x, 'value', 3x, &
     'chkd'/3x, i7, 3(2x, g14.4), 2(g12.4, 3x, a1))
 1020 format (/5x, ' current parameter values', ' (only unfixed para', &
     'meters are listed)')
 1030 format (/' ***** parameter convergence *****')
 1040 format (/' ***** residual sum of squares convergence *****')
 1050 format (/' ***** parameter and residual sum of squares', &
     ' convergence *****')
 1060 format (/'the residual sum of squares is exactly zero')
 1070 format (/' ***** singular convergence *****')
 1080 format (/' false convergence')
 1090 format (/'limit on number of calls to the model subroutine reached')
 1100 format (/'iteration limit reached')
 1110 format (/'stopx ' )
 1120 format (/'initial residual sum of squares overflows ')
 1130 format (/'bad parameters to assess ')
 1140 format (/'derivative matrix could not be computed ')
 1150 format (/5x, ' current parameter values')
end
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 )

!*****************************************************************************80
!
!! NLMN: controlling routine for nonlinear least squares regression.
!
!  Discussion:
!
!    This is the controlling routine for performing nonlinear
!    least squares regression using the nl2 software package
!    (implementing the method of dennis, gay and welsch).
!    this subroutine was adapted from subroutine nl2sol.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    John Dennis, David Gay, Roy Welsch,
!    An Adaptive Nonlinear Least Squares Algorithm,
!    ACM Transactions on Mathematical Software,
!    Volume 7, Number 3, 1981.
!
  implicit none

  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
!
!  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)
!
!  subroutine arguments
  external drv,mdl,nldrv,nlhdr
!
!  scalars in common
  integer &
     ierr

  real &
     wtsqrt
  integer &
     cnvcod,covmat,i,icnvcd,ivcvpt,qtr,rd,rdi,rsave,rsshlf,s, &
     scl
  logical &
     cmpdrv,done,head,newitr,prtsmy
!
!  local arrays
  integer &
     iskull(10)
!
!  external subroutines
  external nl2itr,nlerr,nlfin,nlinit,nlism,nlitrp,nlsupk
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical aprxdv
!        the variable used to indicate whether numerical
!        approximations to the derivative were used (true) or not
!        (false).
!     logical cmpdrv
!        the variable used to indicate whether derivatives must be
!        computed (true) or not (false).
!     integer cnvcod
!        a value used to control the printing of iteration reports.
!     integer covmat
!        the location in iwork of the starting location in rwork
!        of the beginning of the vcv matrix.
!     real d(n,npar)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     logical done
!        the variable used to indicate whether this is the final
!        computation of the jacobian or not.
!     logical head
!        the variable used to indicate whether a heading is to be
!        printed during a given call to the iteration report (true)
!        or not (false).
!     logical hlfrpt
!        the variable which indicates whether the derivative
!        checking routine has already printed part of the
!        initial summary (true) or not (false).
!     integer i
!        an indexing variable.
!     integer icnvcd
!        the location in iwork of
!        the convergence condition.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer iiwork
!        the dimension of the integer work vector iwork.
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer irwork
!        the dimension of the real work vector rwork.
!     integer iskull(10)
!        an error message indicator variable.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!     integer iwork(iiwork)
!        the integer work space vector used by the nl2 subroutines.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer lscale
!        the actual length of the vector scale.
!     integer lstp
!        the actual length of the vector stp.
!     integer lvcvl
!        the length of the vector containing
!        the lower half of the vcv matrix, stored row wise.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     logical newitr
!        a flag used to indicate whether a new iteration has been
!        completed (true) or not (false).
!     external nldrv
!        the name of the routine which calculated the derivatives
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the current estimates of the parameters.
!     real pare(npar)
!        the current estimates of the parameters, but only
!        those to be optimized (not those whose values are fixed).
!     logical prtsmy
!        the variable used to indicate whether the summary
!        information is to be printed (true) or not (false).
!     real pv(n)
!        the predicted values.
!     integer qtr
!        the location in iwork of the starting location in rwork
!        the array q transpose r.
!     integer rd
!        the location in iwork of the starting location in rwork of
!        the diagonal elements of the r matrix of the q - r
!        factorization of d.
!     integer rdi
!        the location in rwork of the diagonal elements of the r
!        matrix of the q - r factorization of d.
!     real res(n)
!        the residuals from the fit.
!     integer rsave
!        the location in iwork of the starting location in rwork
!        the array rsave.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     integer rsshlf
!        the location in rwork of
!        half the residual sum of squares.
!     real rwork(irwork)
!        the real work vector used by the nl2 subroutines.
!     integer s
!        the location in iwork of the starting location in rwork
!        the array of second order terms of the hessian.
!     real scale(lscale)
!        the typical size of the parameters.
!     integer scl
!        the index in rwork of the 1st value of the user supplied scale
!        value.
!     integer sdpvi
!        the starting location in rwork of
!        the standard deviations of the predicted values.
!     integer sdresi
!        the starting location in rwork of the
!        the standardized residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!        predicted decrease in the residual standard deviation (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stopss
!        the stopping criterion forthe test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(lstp)
!        the dummy step size array.
!     integer vcvl
!        the starting location in rwork of the lower half of the
!        vcv matrix, stored row wise.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real wtsqrt
!        the square root of the user supplied weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!  iwork subscript values
!
  data cnvcod /34/, icnvcd /1/, covmat /26/, qtr /49/, rd /51/, &
     rsave /52/, s/53/
  data rsshlf /10/
!
!  initialize control parameters
!
  call nlinit (n, ifixd, par, npar, pare, npare, mit, stopss, &
     stopp, scale, lscale, delta, ivaprx, aprxdv, ivcvpt, iwork, &
     iiwork, rwork, irwork, scl)

  cmpdrv = .true.
  done = .false.
  head = .true.
  newitr = .false.
  prtsmy = (iptout(1) /= 0)
!
!  compute residuals
!
   10 call mdl(par, npar, xm, n, m, ixm, pv)

  do i=1,n
     wtsqrt = 1.0e0
     if (weight) wtsqrt = sqrt(wt(i))
     res(i) = wtsqrt*(y(i)-pv(i))
  end do
!
!  print initial summary
!
  if ( prtsmy ) then
    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.
  end if

  if (.not.cmpdrv) go to 50

  cmpdrv = .false.

   40 continue
!
!  print iteration report if desired
!
  if ((iptout(2) /= 0) .and. newitr) call nlitrp(nlhdr, head, page, &
     wide, iptout(2), npar, nnzw, iwork, iiwork, rwork, irwork, &
     ifixd, pare, npare)
!
!  compute jacobian
!
  if (done) call mdl(par, npar, xm, n, m, ixm, pv)

  call nldrv (mdl, drv, done, ifixd, par, npar, xm, n, m, ixm, &
     pv, d, weight, wt, lwt, stp, lstp, rwork(scl), npare)

  if (done) go to 70
!
!  compute next iteration
!
   50 call nl2itr(rwork(scl), iwork, d, n, n, npare, res, rwork, pare)
!
!  unpack parameters
!
  call nlsupk(pare, npare, par, ifixd, npar)

  newitr = (iwork(cnvcod) == 0)
  if (iwork(1)-2) 10, 40, 60

   60 done = .true.
  go to 40
   70 continue
!
!  set error flags, if necessary
!
  call nlerr(iwork(icnvcd), iskull)
!
!  finish computations and print any desired results
!
!  equivalence locations within rwork.
!
  sdpvi = iwork(rsave)
  sdresi = iwork(qtr)
  vcvl = iwork(covmat)
  if (vcvl >= 1) go to 80

  vcvl = iwork(s)

  if ( ierr == 0 ) then
    iskull(1) = 1
    iskull(7) = 1
    ierr = 7
  end if

   80 continue

  lvcvl = npare * ( npare + 1 ) / 2

  rdi = iwork(rd)

  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 )

  return
end
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 )

!*****************************************************************************80
!
!! NLOUT prints the final summary report for nonlinear least squares routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     cond,rsd,rss,yss
  integer &
     idf,ivcvpt,ixm,lvcvl,lwt,m,n,ndigit,nnzw,npar,npare
  logical &
     exact,page,weight,wide
!
!  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)
!
!  subroutine arguments
  external nlhdr
!
!  scalars in common
  integer &
     ierr

  real &
     fplm,pll,pul,ratio,sdpar,t
  integer &
     i,ipk,ipk2,isubhd
!
!  external functions
  real &
     ppft
  external ppft
!
!  external subroutines
  external fitpt1,fitpt2,nlskl,vcvotf
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real cond
!        the condition number of d.
!     logical exact
!        an indicator value used to designate whether the fit
!        was exact to machine precision (true) or not (false).
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an indexing variable.
!     integer idf
!        the degrees of freedom in the fit.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!        if ifixed(i) /= 0, then par(i) will be held fixed.
!        if ifixed(i) == 0, then par(i) will be optimized.
!     integer ipk
!        an index.
!     integer ipk2
!        the index of the "diagonal" element of the vcv
!        matrix.
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer iskull(10)
!        an error message indicator variable.
!     integer isubhd
!        an integer value specifying subheadings to be printed.
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!     integer ixm
!        the first dimension of the independent variable array.
!     integer lvcvl
!        the length of the vector contaning
!        the lower half of the vcv matrix, stored row wise.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer ndigit
!        the number of digits in the print control value.
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     real par(npar)
!        the parameter estimates.
!     logical page
!        the variable used to indicate whether or not the output
!        is to begin on a new page.
!     real pll, pul
!        the lower and upper confidence limits for a given parameter.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real ratio
!        the ratio of a given parameter value to its standard error.
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     real rss
!        the residual sum of squares.
!     real sdpar
!        the standard deviation of a given parameter value.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     real t
!        the value of the 97.5 percent point function for the
!        t distribution.
!     real vcvl(lvcvl)
!        the lower half of the vcv matrix, stored row wise.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real wt(lwt)
!        the user supplied weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!     real yss
!        the sum of squares of the dependent variable y.
!
  fplm = huge ( fplm )

  if ((ierr >= 1) .and. (ierr /= 4)) go to 60
!
!  Test for exact fit
!
  if ((idf <= 0) .or. exact) go to 70
!
!  Print error heading if necessary
!
  if (ierr == 4) call nlskl(iskull, page, wide, nlhdr)
!
!  Print primary report
!
  if ((ierr /= 0) .or. (iptout(3) /= 0)) then
    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)))
  end if
!
!  Print standardized residual plots
!
  if ( iptout(4) /= 0) then
    isubhd = 0
    call nlhdr(page, wide, isubhd)

    call fitpt2 (sdres, pv, wt, n, nnzw, weight, res, rss)
  end if
!
!  Print the covariance and correlation matrix
!
  if ((ierr == 0) .and. (iptout(5) == 0)) return
  isubhd = 0
  call nlhdr(page, wide, isubhd)

  if ( ierr /= 0 .or. 1 < iptout(5) ) then
    call vcvotf(npare, vcvl, lvcvl, .true., npar, ifixd, ivcvpt)
  end if
!
!  Print analysis summary
!
  write ( *,1000)
  write ( *,1010)

  t = ppft(0.975e0,idf)
  ipk = 0

  do i=1,npar

    if (ifixd(i) == 0) then

      ipk = ipk + 1
      ipk2 = ipk*(ipk-1)/2 + ipk
      ratio = fplm
      sdpar = sqrt(vcvl(ipk2))
      if (sdpar > 0.0e0) ratio = par(i)/sdpar
      pll = par(i) - t*sdpar
      pul = par(i) + t*sdpar
      write ( *,1020) i, par(i), sdpar, ratio, pll, pul

    else

      write ( *,1030) i, par(i)

    end if

  end do

  write ( *,1040) rss, rsd, nnzw, npare, idf
  write ( *,1050) cond

  if (rss > yss) write ( *,1060)

  return
!
!  Print out error heading
!
   60 call nlskl(iskull, page, wide, nlhdr)

  if (ierr <= 2) return
!
!  Print secondary report
!
   70 continue
  isubhd = 0
  call nlhdr(page, wide, isubhd)
  if (ierr /= 0) write ( *,1080)
  write ( *,1000)
  write ( *,1100)
  do i=1,npar
     if (ifixd(i) == 0) then
       write ( *,1110) i, par(i)
     else
       write ( *,1120) i, par(i)
     end if
  end do
  write ( *,1040) rss, rsd, nnzw, npare, idf
  if (ierr /= 3) write ( *,1050) cond

  if ((ierr == 0) .and. (.not.exact) .and. (idf <= 0)) &
     write(*,1070)
  if ((ierr == 0) .and. exact) write ( *,1090)

  if (ierr == 0) then
    sdres(1:n) = 0.0e0
    sdpv(1:n) = 0.0e0
    return
  end if

  sdres(1:n) = fplm
  sdpv(1:n) = fplm
!
!  Print out error exit statistics
!
  call fitpt1 ( n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, nnzw, &
     weight, max(iptout(3),1) )
!
!  Wipe out sdres vector
!
  sdres(1:n) = fplm
!
!  Wipe out vcv matrix
!
  vcvl(1:lvcvl) = fplm

  return

 1000 format (///' estimates from least squares fit'/1x, 33('-'))
 1010 format (//69x, 'approximate'/61x, '95 percent confidence limits '&
     /1x, 'index', 2x, 'fixed', 3x, 'parameter', 8x, 'sd of par', &
     7x, 'ratio', 12x, 'lower', 12x, 'upper'/)
 1020 format (1x, i3, 5x, ' no', 2g17.8, 2x, g10.4, 2g17.8)
 1030 format (1x, i3, 5x, 'yes', g17.8, 10x, '---', 8x, '---', 15x, &
     '---', 14x, '---')
 1040 format (//' residual sum of squares       ', 8x, g15.7//' resid', &
     'ual standard deviation   ', 8x, g15.7/' based on degrees o', &
     'f freedom', 5x, i4, ' - ', i3, ' = ', i4)
 1050 format (/' approximate condition number', 10x, g15.7)
 1060 format (' the residual sum of squares after the least squares', &
     ' fit is greater than'/' the sum of squares about the mean ', &
     'y observation.  the', ' model is less'/' representative o', &
     'f the data than a simple average.  data', ' and model shou', &
     'ld'/' be checked to be sure that they are compatable.')
 1070 format (/' the degrees of freedom for this problem is zero.', &
     '  statistical analysis of the results is not possible.')
 1080 format (//' the following summary should be used to', ' analyze', &
     ' the above mentioned problems.')
 1090 format (/' the least squares fit of the data to the model is', &
     ' exact to within machine precision.'/' statistical analysi', &
     's of the results is not possible.')
 1100 format (//1x, 'index', 2x, 'fixed', 3x, 'parameter')
 1110 format (1x, i3, 5x, ' no', g17.8)
 1120 format (1x, i3, 5x, 'yes', g17.8)
end
subroutine nlsc ( y, xm, n, m, ixm, mdl, par, npar, res, ldstak, &
     ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, nprt )

!*****************************************************************************80
!
!! NLSC: NLS regression, approximate derivatives (control call)
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using numerically approximated derivatives
!    (control call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,stopp,stopss
  integer &
     ivaprx,ixm,ldstak,m,mit,n,npar,nprt
!
!  array arguments
  real &
     par(*),res(*),scale(*),stp(*),xm(*),y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     rsd
  integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,nnzw, &
     npare
  logical &
     save,weight
!
!  local arrays
  real &
     pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcntn
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(npar)
!        the step size array.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the dummy array for the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','c',' ',' '/

  weight = .false.
  save = .false.

  wt(1) = 1.0e0
  lifixd = npar
  lpv = 1
  lscale = npar
  lstp = npar
  lsdpv = 1
  lsdres = 1
  lwt = 1
  ivcv = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' 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
subroutine nlsdc ( y, xm, n, m, ixm, mdl, drv, par, npar, res, &
     ldstak, ifixed, idrvck, mit, stopss, stopp, scale, delta, &
     ivaprx, nprt )

!*****************************************************************************80
!
!! NLSDC: NLS regression, analytic derivatives, user parameters.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using analytic derivatives with user
!    supplied control parameters.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,stopp,stopss
  integer &
     idrvck,ivaprx,ixm,ldstak,m,mit,n,npar,nprt
!
!  array arguments
  real &
     par(*),res(*),scale(*),xm(*),y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     rsd
  integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lwt,nnzw,npare
  logical &
     save,weight
!
!  local arrays
  real &
     pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcnta
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idrvck
!        the variable used to indicate whether or not the derivatives we
!        checked or not.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real vcv(1,1)
!        the starting location in rstak/dstak of
!        the covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the dummy array for the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','d','c',' '/

  weight = .false.
  save = .false.

  wt(1) = 1.0e0
  lifixd = npar
  lpv = 1
  lscale = npar
  lsdpv = 1
  lsdres = 1
  lwt = 1
  ivcv = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' 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
subroutine nlsd ( y, xm, n, m, ixm, mdl, drv, par, npar, res, ldstak )

!*****************************************************************************80
!
!! NLSD: nonlinear least squares regression, analytic derivatives (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,ldstak,m,n,npar
!
!  array arguments
  real &
     par(*),res(*),xm(*),y(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     delta,rsd,stopp,stopss
  integer &
     idrvck,ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres, &
     lwt,mit,nnzw,npare,nprt
  logical &
     save,weight
!
!  local arrays
  real &
     pv(1),scale(1),sdpv(1),sdres(1),vcv(1,1),wt(1)
  integer &
     ifixed(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcnta
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idrvck
!        the variable used to indicate whether or not the derivatives we
!        checked or not.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(1)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the dummy array for the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','d',' ',' '/

  weight = .false.
  save = .false.

  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

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call nlsd (y, xm, n, m, ixm, nlsmdl, nlsdrv,'/ &
     '      +           par, npar, res, ldstak)')
end
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 )

!*****************************************************************************80
!
!! NLSDS: NLS regression, analytic derivatives, user parameters.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using analytic derivatives with user
!    supplied control parameters, and with computed values returned
!    to the user.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,rsd,stopp,stopss
  integer &
     idrvck,ivaprx,ivcv,ixm,ldstak,m,mit,n,npar,npare,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),vcv(*),xm(*), &
     y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer lifixd,lpv,lscale,lsdpv,lsdres,lwt,nnzw
  logical &
     save,weight
!
!  local arrays
  real &
     wt(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcnta
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idrvck
!        the variable used to indicate whether or not the derivatives we
!        checked or not.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        the typical size of the parameters.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real vcv(ivcv,npar)
!        the covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the dummy array for the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','d','s',' '/

  weight = .false.
  save = .true.

  wt(1) = 1.0e0
  lifixd = npar
  lpv = n
  lscale = npar
  lsdpv = n
  lsdres = n
  lwt = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' 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
subroutine nls ( y, xm, n, m, ixm, mdl, par, npar, res, ldstak )

!*****************************************************************************80
!
!! NLS: NLS regression with numeric derivatives, short call.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using numerically approximated derivatives
!    (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,ldstak,m,n,npar
!
!  array arguments
  real &
     par(*),res(*),xm(*),y(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     delta,rsd,stopp,stopss
  integer ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt, &
     mit,nnzw,npare,nprt
  logical &
     save,weight
!
!  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
!
!  external subroutines
  external nlcntn
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(1)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(1)
!        the step size array.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the dummy array for the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s',' ',' ',' '/

  weight = .false.
  save = .false.

  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

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call nls (y, xm, n, m, ixm, nlsmdl,'/ &
     '      +          par, npar, res, ldstak)')
end
subroutine nlskl ( iskull, page, wide, nlhdr )

!*****************************************************************************80
!
!! NLSKL prints warning messages for the nonlinear least squares routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  logical &
     page,wide
!
!  array arguments
  integer &
     iskull(10)
!
!  subroutine arguments
  external nlhdr
!
!
  integer &
     isubhd
!
!     variable definitions (alphabetically)
!
!     external nlhdr
!        the name of the routine which produces the heading.
!     integer iskull(10)
!        an error message indicator variable.
!     integer isubhd
!        an integer value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether or not the output
!        is to begin on a new page.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!

  isubhd = 0
  call nlhdr(page, wide, isubhd)

  if (wide) then
     write ( *,1010)
     write ( *,1020)
     write ( *,1000)
  end if
  write ( *,1060)
!
!  vcv computation not completed
!
  if (iskull(7) /= 0) write ( *,1120)
!
!  maximum number of iterations reached before convergence
!
  if (iskull(6) /= 0) write ( *,1100)
!
!  false convergence
!
  if (iskull(5) /= 0) write ( *,1090)
!
!  meaningless vcv matrix
!
  if (iskull(4) /= 0) write ( *,1080)
!
!  problem is computationally singular
!
  if (iskull(3) /= 0) write ( *,1070)
!
!  initial residual sum of squares computation overflowed
!
  if (iskull(2) /= 0) write ( *,1110)

  return

 1000 format (///)
 1010 format (/'WARNING')
 1020 format ('WARNING'/)
 1060 format (' **  error summary  **')
 1070 format (/' this model and data are computationally singular.', &
     ' check your input for errors.')
 1080 format (/' at least one of the standardized residuals', ' could', &
     ' not be computed because the standard deviation', ' of the ', &
     'residual was zero.'/' the validity of the covariance matri', &
     'x is questionable.')
 1090 format (/' the iterations do not appear to be converging', &
     ' to a minimum', ' (false convergence), indicating that the', &
     ' convergence', ' criteria stopss'/' and stopp may be too ', &
     'small for the accuracy of the model', ' and derivatives,', &
     ' that there is an error in the derivative matrix, or'/ &
     ' that the model', ' is discontinuous near the current coef', &
     'ficient estimates.')
 1100 format (/' program did not converge in the number of iterations', &
     ' or number of', ' model subroutine calls allowed.')
 1110 format (/' the residual sum of squares could not be computed', &
     ' using the starting', ' model coefficient values.')
 1120 format (/' the variance-covariance matrix could not be', &
     ' computed at the solution.')
end
subroutine nlspk ( par, mask, npar, ppar, nppar )

!*****************************************************************************80
!
!! NLSPK packs the unmasked elements of one vector into another.
!
!  Discussion:
!
!    This routine packs a vector par into a vector ppar, by
!    omitting from the packed version those elements of the
!    unpacked version corresponding to elements of mask which
!    have the value 1.  other elements of mask should be zero.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     npar,nppar
!
!  array arguments
  real &
     par(npar),ppar(nppar)
  integer &
     mask(npar)
!
!
  integer &
     i,ippar
!
!     variable definitions (alphabetically)
!
!     real par(npar)
!        input parameter.  the unpacked vector.
!     integer i
!        loop parameter.
!     integer ippar
!        current element of ppar.  ranges from 0 (on initialization)
!        to nppar.
!     integer mask(npar)
!        input parameter.  the mask governing the packing of par.
!        elements of mask are 1 if the corresponding element of par
!        is to be eliminated in ppar, 0 if it is to be included.
!     integer npar
!        input parameter.  the length of par.
!     integer nppar
!        input parameter.  the length of ppar.
!     real ppar(nppar)
!        output parameter.  the packed version of par.  see initial
!        description.
!
  ippar = 0
  do i=1,npar
    if ( mask(i) == 0 ) then
      ippar = ippar + 1
      ppar(ippar) = par(i)
    end if
  end do

  return
end
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 )

!*****************************************************************************80
!
!! NLSS: interface, nonlinear least squares reqression, approximate derivatives.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using numerically approximated derivatives
!    (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,rsd,stopp,stopss
  integer &
     ivaprx,ivcv,ixm,ldstak,m,mit,n,npar,npare,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), &
     xm(*),y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,nnzw
  logical &
     save,weight
!
!  local arrays
  real &
     wt(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcntn
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(npar)
!        the step size array.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(1)
!        the dummy array for the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','s',' ',' '/

  weight = .false.
  save = .true.

  wt(1) = 1.0e0
  lifixd = npar
  lpv = n
  lscale = npar
  lstp = npar
  lsdpv = n
  lsdres = n
  lwt = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' 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
subroutine nlsupk ( pare, npare, par, mask, npar )

!*****************************************************************************80
!
!! NLSUPK unpacks a vector into another, using a mask vector.
!
!  Discussion:
!
!    This routine unpacks a vector pare into a vector par, by
!    placing succeding elements of pare into elements of par
!    which correspond to elements of mask with the value 1.
!    other elements of mask should be 0.  the number of elements
!    npare in pare should equal the number of elements of
!    mask which are 1.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real par(npar)
!        the current estimates of the parameters.
!     integer jpk
!        an index variable.
!     integer mask(npar)
!        input parameter.  the mask governing the packing of par.
!        elements of mask are 1 if the corresponding element of par
!        was eliminated in pare, 0 if it was included.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be optimized.
!     real pare(npare)
!        the current estimates of the parameters being optimized,
!        not including those whose values are fixed.
!
  implicit none

  integer npar
  integer npare

  integer mask(npar)
  real par(npar)
  real pare(npare)
!
!
  integer &
     i,jpk

  jpk = 0

  do i=1,npar

    if ( mask(i) == 0 ) then
      jpk = jpk + 1
      par(i) = pare(jpk)
    end if

  end do

  return
end
subroutine nlswc ( y, wt, xm, n, m, ixm, mdl, par, npar, res, &
     ldstak, ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, &
     nprt )

!*****************************************************************************80
!
!! NLSWC: nonlinear least squares regression, weights, approximate derivatives.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using numerically approximated derivatives
!    and weights (control call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,stopp,stopss
  integer &
     ivaprx,ixm,ldstak,m,mit,n,npar,nprt
!
!  array arguments
  real &
     par(*),res(*),scale(*),stp(*),wt(*),xm(*),y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     rsd
  integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,nnzw, &
     npare
  logical &
     save,weight
!
!  local arrays
  real &
     pv(1),sdpv(1),sdres(1),vcv(1,1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcntn
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(npar)
!        the step size array.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','w','c',' '/

  weight = .true.
  save = .false.

  lifixd = npar
  lpv = 1
  lscale = npar
  lstp = npar
  lsdpv = 1
  lsdres = 1
  lwt = n
  ivcv = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' 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
subroutine nlswdc ( y, wt, xm, n, m, ixm, mdl, drv, par, npar, res, &
     ldstak, ifixed, idrvck, mit, stopss, stopp, scale, delta, &
     ivaprx, nprt )

!*****************************************************************************80
!
!! NLSWDC: NLS regression, analytic derivatives, weights, user parameters.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using analytic derivatives, weights, and
!    user supplied control parameters.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,stopp,stopss
  integer &
     idrvck,ivaprx,ixm,ldstak,m,mit,n,npar,nprt
!
!  array arguments
  real &
     par(*),res(*),scale(*),wt(*),xm(*),y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     rsd
  integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lwt,nnzw,npare
  logical &
     save,weight
!
!  local arrays
  real &
     pv(1),sdpv(1),sdres(1),vcv(1,1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcnta
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idrvck
!        the variable used to indicate whether the derivatives are
!        to be checked (idrvck = 1) or not (idrvck = 0).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if ifixed(i).eq
!        then par(i) will be held fixed.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real vcv(1,1)
!        a dummy array for
!        the variance-covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','w','d','c'/

  weight = .true.
  save = .false.

  lifixd = npar
  lpv = 1
  lscale = npar
  lsdpv = 1
  lsdres = 1
  lwt = n
  ivcv = 1

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' 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
subroutine nlswd ( y, wt, xm, n, m, ixm, mdl, drv, par, npar, res, ldstak )

!*****************************************************************************80
!
!! NLSWD: NLS regression, analytic derivatives, weights (short call).
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using analytic derivatives and weights
!    (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,ldstak,m,n,npar
!
!  array arguments
  real &
     par(*),res(*),wt(*),xm(*),y(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     delta,rsd,stopp,stopss
  integer &
     idrvck,ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres, &
     lwt,mit,nnzw,npare,nprt
  logical &
     save,weight
!
!  local arrays
  real &
     pv(1),scale(1),sdpv(1),sdres(1),vcv(1,1)
  integer &
     ifixed(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcnta
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idrvck
!        the variable used to indicate whether or not the derivatives we
!        checked or not.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if ifixed(i).eq
!        then par(i) will be held fixed.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of indendent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(1)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','w','d',' '/

  weight = .true.
  save = .false.

  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

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call nlswd (y, wt, xm, n, m, ixm, nlsmdl, nlsdrv,'/ &
     '      +            par, npar, res, ldstak)')
end
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 )

!*****************************************************************************80
!
!! NLSWDS: NLS regression with analytic derivatives, weights, user parameters.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using analytic derivatives, weights, and
!    user supplied control parameters, and with computed values
!    returned to the user.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,rsd,stopp,stopss
  integer &
     idrvck,ivaprx,ivcv,ixm,ldstak,m,mit,n,nnzw,npar,npare,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),vcv(*),wt(*), &
     xm(*),y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external drv,mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer lifixd,lpv,lscale,lsdpv,lsdres,lwt
  logical &
     save,weight
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcnta
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     external drv
!        the name of the user supplied subroutine which computes the
!        derivative (jacobian) matrix of the model.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idrvck
!        the variable used to indicate whether the derivatives are
!        to be checked (idrvck = 1) or not (idrvck = 0).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if ifixed(i).eq
!        then par(i) will be held fixed.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        the typical size of the parameters.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual standard deviation (computed
!        by starpac) to the current residual sum of squares estimate.
!     real vcv(ivcv,npar)
!        the variance-covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'n',       'l',       's',       'w',       'd',       's'/

  weight = .true.
  save = .true.

  lifixd = npar
  lpv = n
  lscale = npar
  lsdpv = n
  lsdres = n
  lwt = n

  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)

  if (ierr /= 1) return
  write ( *, 1000)
  return

 1000 format (/' 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)')

end
subroutine nlsw ( y, wt, xm, n, m, ixm, mdl, par, npar, res, ldstak )

!*****************************************************************************80
!
!! NLSW: NLS regression with approximate derivatives and weights.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using numerically approximated derivatives
!    and weights (short call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,ldstak,m,n,npar
!
!  array arguments
  real &
     par(*),res(*),wt(*),xm(*),y(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     delta,rsd,stopp,stopss
  integer ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt, &
     mit,nnzw,npare,nprt
  logical &
     save,weight
!
!  local arrays
  real &
     pv(1),scale(1),sdpv(1),sdres(1),stp(1),vcv(1,1)
  integer &
     ifixed(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcntn
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(1)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(1)
!        a dummy array for
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(1)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(1)
!        a dummy array for
!        the standard deviation of the predicted value.
!     real sdres(1)
!        a dummy array for
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(1)
!        the step size array.
!     real vcv(1,1)
!        a dummy array for
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','w',' ',' '/

  weight = .true.
  save = .false.

  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

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call nlsw (y, wt, xm, n, m, ixm, nlsmdl,'/ &
     '      +           par, npar, res, ldstak)')
end
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 )

!*****************************************************************************80
!
!! NLSWS: NLS regression with approximate derivatives and weights.
!
!  Discussion:
!
!    This is the user callable subroutine for nonlinear least
!    squares regression using numerically approximated derivatives
!    and weights (long call).
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,rsd,stopp,stopss
  integer &
     ivaprx,ivcv,ixm,ldstak,m,mit,n,nnzw,npar,npare,nprt
!
!  array arguments
  real &
     par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), &
     wt(*),xm(*),y(*)
  integer &
     ifixed(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt
  logical &
     save,weight
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external nlcntn
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifixed(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if ifixed(i).eq
!        then par(i) will be held fixed.
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the actual length of the vector ifixed.
!     integer lpv
!        the actual length of the vector pv.
!     integer lscale
!        the actual length of the vector scale.
!     integer lsdpv
!        the actual length of the vector sdpv.
!     integer lsdres
!        the actual length of the vector sdres.
!     integer lstp
!        the actual length of the vector stp.
!     integer lwt
!        the actual length of the vector wt.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimate.   n
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer nnzw
!        the number of non zero weights.
!     integer npar
!        the number of parameters in the model.
!     integer npare
!        the number of parameters to be estimated.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(npar)
!        the current estimates of the parameters.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real rsd
!        the value of the residual standard deviation at the solution.
!     logical save
!        the variable used to indicate whether any results other than
!        the residuals and parameters are to be saved (true) or not
!        (false).
!     real scale(npar)
!        a value to indicate use of the default values of
!        the typical size of the parameters.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual sum of squares (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(npar)
!        the step size array.
!     real vcv(ivcv,npar)
!        the variance covariance matrix.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'n','l','s','w','s',' '/

  weight = .true.
  save = .true.

  lifixd = npar
  lpv = n
  lscale = npar
  lstp = npar
  lsdpv = n
  lsdres = n
  lwt = n

  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)

  if (ierr /= 1) return
  write ( *,1000)
  return

 1000 format (/' 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
subroutine nlsx1 ( mod, par, npar, pv, sdpv, res, sdres, vcv, n, &
     ivcv, nnzw, npare, rsd )

!*****************************************************************************80
!
!! NLSX1 sets the starting parameter values for NLSX.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     rsd
  integer &
     ivcv,mod,n,nnzw,npar,npare
!
!  array arguments
  real &
     par(npar),pv(n),res(n),sdpv(n),sdres(n),vcv(ivcv,ivcv)
!
!  scalars in common
  integer &
     ierr
!
!  external subroutines
  external setrv
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ivcv
!        the actual first dimension of vcv.
!     integer mod
!        an indicator value used to designate the model for which
!        the parameters are to be set.
!     integer n
!        the number of observations.
!     integer npar
!        the number of parameters in the model.
!        to be provided.
!     integer npare
!        the number of parameters estimated by the routine.
!     integer nnzw
!        the number of nonzero weights.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real pv(n)
!        the predicted values.
!     real res(n)
!        the residuals.
!     real rsd
!        the residual standard deviation.
!     real sdpv(n)
!        the standard deviation of the predicted values.
!     real sdres(n)
!        the standardized residuals.
!     real vcv(ivcv,ivcv)
!        the variance covariance matrix.
!
  if ( mod == 1 ) then
    par(1) = 0.725e0
    par(2) = 4.0e0
  else if ( mod == 2 ) then
    par(1) = 1.0e0
    par(2) = 2.0e0
    par(3) = 3.0e0
  else if ( mod == 3 ) then
    par(1) = 6.0e0
    par(2) = 5.0e0
    par(3) = 4.0e0
    par(4) = 3.0e0
    par(5) = 2.0e0
  else if ( mod == 4 ) then
    call setrv(par, npar, 0.0e0)
  else if ( mod == 5 ) then
    call setrv(par, npar, 0.5e0)
  else if ( mod == 6 ) then
    par(1) = 100.0e0
    par(2) = 15.0e0
  end if

  res(1:n) = -1.0e0
  pv(1:n) = -1.0e0
  sdpv(1:n) = -1.0e0
  sdres(1:n) = -1.0e0
  vcv(1:ivcv,1:ivcv) = -1.0e0
  nnzw = -1
  npare = -1
  rsd = -1.0e0

  ierr = -1

  return
end
subroutine nlsx2 ( n, m, ixm, npar, ifixed, stp, idrvck, mit, &
     stopss, stopp, scale, delta, ivaprx, nprt, ivcv )

!*****************************************************************************80
!
!! NLSX2 sets a problem for testing the NLS family.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,stopp,stopss
  integer &
     idrvck,ivaprx,ivcv,ixm,m,mit,n,npar,nprt
!
!  array arguments
  real &
     scale(10),stp(10)
  integer &
     ifixed(10)
!
!
  real &
     sqmeps
!
!  external functions
  real &
     rmdcon
  external rmdcon
!
!     variable definitions (alphabetically)
!
!     real delta
!        the maximum change allowed in the model parameters at the
!        first iteration.
!     integer idrvck
!        the variable used to indicate whether the derivatives are
!        to be checked (idrvck = 1) or not (idrvck = 0).
!     integer ifixed(10)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!        ifixed(i)<0, then all par(i),i=1,npar, will be optimized..
!     integer ivaprx
!        an indicator value used to designate which option is to be used
!        to compute the variance covariance matrix (vcv), where
!        ivaprx le 0 indicates the the default option will be used
!        ivaprx eq 1 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 2 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 3 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using both the model subroutine the user supplied
!                    derivative subroutine when it is available
!        ivaprx eq 4 indicates the vcv is to be computed by
!                       inverse(hessian)*transpose(jacobian)*jacobian
!                          *inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 5 indicates the vcv is to be computed by
!                       inverse(hessian)
!                    using only the model subroutine
!        ivaprx eq 6 indicates the vcv is to be computed by
!                       inverse(transpose(jacobian)*jacobian)
!                    using only the model subroutine
!        ivaprx ge 7 indicates the default option will be used
!     integer ivcv
!        the first dimension of the variance covariance matrix vcv.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer m
!        the number of independent variables.
!     integer mit
!        the maximum number of iterations allowed.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real scale(10)
!        a value to indicate use of the default values of
!        the typical size of the unknown parameters.
!     real sqmeps
!        the square root of machine precision
!     real stopp
!        the stopping criterion for the test based on the maximum scaled
!        relative change in the elements of the model parameter vector
!     real stopss
!        the stopping criterion for the test based on the ratio of the
!        predicted decrease in the residual standard deviation (computed
!        by starpac) to the current residual sum of squares estimate.
!     real stp(10)
!        the step size array.
!
  sqmeps = sqrt( epsilon ( sqmeps ) )

  n = 6
  m = 1
  ixm = 10
  npar = 2
  mit = 500
  stp(1:10) = sqmeps
  scale(1:10) = 1.0e0
  ifixed(1) = -1
  idrvck = 0
  stopss = 10.0e-5
  stopp = 10.0e-5
  delta = 0.5e0
  nprt = 11111
  ivaprx = 3
  ivcv = 6

  return
end
subroutine nrandc ( y, n, iseed, ymean, sigma )

!*****************************************************************************80
!
!! NRANDC generates pseudorandom normally distributed values.
!
!  Discussion:
!
!    This routine generates n normally distributed pseudo-
!    random numbers with mean ymean and standard deviation sigma.  the
!    numbers generated are determined by iseed.  they are returned in y
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, John Koontz, Peter Tryon,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sigma,ymean
  integer &
     iseed,n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,iseedu
  logical &
     err01,err02,head
!
!  local arrays
  character &
     ln(8)*1,lone(8)*1,lsigma(8)*1,lzero(8)*1,nmsub(6)*1
!
!  external functions
  real &
     randn
  external randn
!
!  external subroutines
  external eisge,eisrng,ersge
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01, err02
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading sould be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!          the index of the computing loop
!     integer ierr
!        the integer value returned by theis routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been found.
!     integer iseed
!        the iseed to the random number generator.
!        iseed must lie between 0 and 2**((min(32,i1mach(8)+1))-1) -1,
!        inclusive.  if iseed is not equal to 0, iseed must be odd.
!     integer iseedu
!        the value of the seed actually used.
!     character*1 ln(8), lone(8), lsigma(8), lzero(8)
!        the array(s) containing the name(s) of the variables(s) checked
!        for errors
!     integer n
!        the length of data set generated
!     character*1 nmsub(6)
!        the name of this subroutine
!     real sigma
!        the standard deviation of the generated values.
!     real y(n)
!        the generated random values.
!     real ymean
!        the mean of the generated values.
!
  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', ' ', ' ', ' ', ' '/

  ierr = 0

  head = .true.

  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)

  if (err01.or.err02) then

    write ( *,1000)
    ierr = 1

  else
!
!  generate the pseudo-random numbers
!
    y(1) = randn(iseedu)
    do i=1,n
       y(i) = randn(0)*sigma + ymean
    end do
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call nrandc (y, n, iseed, ymean, sigma)')
end
subroutine nrand ( y, n, iseed )

!*****************************************************************************80
!
!! NRAND generates pseudorandom normally distributed values.
!
!  Discussion:
!
!    This routine generates n normally distributed pseudo-
!    random numbers with zero mean and unit standard deviation.  the
!    numbers generated are determined by iseed.  they are returned in y
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, John Koontz, Peter Tryon,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iseed,n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,iseedu
  logical &
     err01,head
!
!  local arrays
  character &
     ln(8)*1,lone(8)*1,nmsub(6)*1
!
!  external functions
  real &
     randn
  external randn
!
!  external subroutines
  external eisge,eisrng
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading sould be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!          the index of the computing loop
!     integer ierr
!        the integer value returned by theis routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been found.
!     integer iseed
!        the iseed to the random number generator.
!        iseed must lie between 0 and 2**((min(32,i1mach(8)+1))-1) -1,
!        inclusive.  if iseed is not equal to 0, iseed must be odd.
!     integer iseedu
!        the value of the seed actually used.
!     character*1 ln(8), lone(8)
!        the array(s) containing the name(s) of the variables(s) checked
!        for errors
!     integer n
!        the length of data set generated
!     character*1 nmsub(6)
!        the name of this subroutine
!     real y(n)
!        the generated random values.
!
  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', ' ', ' ', ' ', ' ', ' '/

  ierr = 0

  head = .true.

  call eisge(nmsub, ln, n, 1, 2, head, err01, lone)
  call eisrng(nmsub, iseed, iseedu, head)

  if (err01) then
    write ( *,1000)
    ierr = 1
    return
  end if
!
!  generate the pseudo-random numbers
!
  y(1) = randn(iseedu)

  do i=1,n
    y(i) = randn(0)
  end do

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call nrand(y, n, iseed)')
end
function numxer ( nerr )

!*****************************************************************************80
!
!! NUMXER returns the most recent error number.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Output, integer NERR, the most recent error number.
!
!    Output, integer NUMXER, the most recent error number.
!
  implicit none

  integer j4save
  integer nerr
  integer numxer
  logical set
  integer value
  integer which

  which = 1
  value = 0
  set = .false.

  nerr = j4save ( which, value, set )

  numxer = nerr

  return
end
subroutine oanova ( ysum, red, npar, rvar, nnzw, temp )

!*****************************************************************************80
!
!! OANOVA computes and prints analysis of variance.
!
!  Modified:
!
!    02 May 2006
!
!  Author:
!
!    Janet Donaldson, David Hogben,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     rvar,ysum
  integer &
     nnzw,npar
!
!  array arguments
  real &
     red(npar),temp(npar)

  real &
     asum,cr,f1,f2,fplm,pf1,pf2,resms,resss,ssu,v1f2,vr
  integer &
     i,k,nsua
!
!  external functions
  real &
     cdff
  external cdff
!
!     variable definitions (alphabetically)
!
!     real fplm
!        the floating point largest magnitude.
!     integer npar
!        the number of parameters.
!     integer nnzw
!        the number of non zero weights.
!     real red(npar)
!        the reduction to the sum of squares due to each parameter.
!     real rvar
!        the residual variance.
!     real temp(npar)
!        a work vector.
!     real ysum
!        the sum of the weighted dependent variables squared.
!
  fplm = huge ( fplm )

  resms = ysum / real ( nnzw )
  nsua = nnzw
  write ( *,1000)
  asum = 0.0e0
  vr = real ( nnzw - npar )
  resss = vr*rvar
  temp(npar) = resss

  do i=2,npar
     k = npar + 2 - i
     temp(k-1) = temp(k) + red(k)
  end do

  v1f2 = real ( npar + 1 )
  ssu = real ( nnzw )

  do i=1,npar

     nsua = nsua - 1
     asum = asum + red(i)
     ssu = ssu - 1.0e0
     cr = asum / real ( i )
     resms = 0.0e0
     if (ssu > 0.0e0) resms = temp(i)/ssu
     v1f2 = v1f2 - 1.0e0
!
!  never pool
!
     if ( rvar <= 0.0e0 ) then
       f1 = fplm
       f2 = fplm
       pf1 = 0.0e0
       pf2 = 0.0e0
     else
       f1 = red(i)/rvar
       pf1 = 1.0e0 - cdff(f1,1.0e0,vr)
!
!  test higher sub-hypotheses
!
       f2 = (temp(i)+red(i)-resss)/v1f2/rvar
       pf2 = 1.0e0 - cdff(f2,v1f2,vr)
     end if

     write ( *,1010) i, red(i), cr, i, resms, nsua, f1, pf1, f2, &
        pf2

  end do

  write ( *,1020) resss, nsua
  write ( *,1030) ysum, nnzw
  return

 1000 format (////50x, 'analysis of variance'/24x, '-dependent on or', &
     'der variables are entered unless vectors are orthogonal-'// &
     1x, ' par     sum of squares', 63x, &
     '------ par=0 ------    ------ pars=0 -----'/ &
     1x, 'index', 4x, 'red due to par', 7x, 'cum ms red', &
     6x, 'df(msred)', 6x, 'cum res ms', 6x, 'df(rms)', 5x, &
     'f', 8x, 'prob(f)', 7x, 'f', 8x, 'prob(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, 'residual  ', 1x, g14.7, 20x, i6)
 1030 format (1x, 'total     ', 1x, g14.7, 20x, i6)
end
subroutine obssm2 ( n, y, pvt, sdpvt, res, sdrest, ifirst, ilast )

!*****************************************************************************80
!
!! OBSSM2 lists the data summary for the arima estimation routines.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ifirst,ilast,n
!
!  array arguments
  real &
     pvt(n),res(n),sdpvt(n),sdrest(n),y(n)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     fplm
  integer &
     i
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an index variable.
!     integer ierr
!        the value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr  >=  1, errors were detected.
!     integer ifirst, ilast
!        the first and last indices to be listed.
!     integer n
!        the number of observations.
!     real pvt(n)
!        the predicted value based on the current parameter estimates.
!     real res(n)
!        the residuals from the fit.
!     real sdpvt(n)
!        the standard deviations of the predicted values.
!     real sdrest(n)
!        the standardized residuals.
!     real y(n)
!        the dependent variable.
!
  fplm = huge ( fplm )

  do i=ifirst,ilast
!
!  print data summary.
!
     if ((sdpvt(i) /= fplm) .and. (sdrest(i) /= fplm)) &
        write ( *, 1060) i, y(i), pvt(i), sdpvt(i), res(i), &
        sdrest(i)
     if ((sdpvt(i) /= fplm) .and. (sdrest(i) == fplm)) &
        write ( *, 1050) i, y(i), pvt(i), sdpvt(i), res(i)
     if ((sdpvt(i) == fplm) .and. (sdrest(i) == fplm)) &
        write ( *, 1080) i, y(i), pvt(i), res(i)

  end do

  return

 1050 format (1x, i4, 4e16.8, 4x, 'nc *', 1x, e9.3)
 1060 format (1x, i4, 4e16.8, 1x, f7.2, 1x, e9.3)
 1080 format (1x, i4, 2e16.8, 8x, 'nc *', 4x, e16.8, 4x, 'nc *', &
     1x, e9.3)
end
subroutine obssum ( n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, &
     weight, k, ifirst, ilast, jcol1, jcolm )

!*****************************************************************************80
!
!! OBSSUM lists the data summary for the least squares subroutines.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ifirst,ilast,ixm,jcol1,jcolm,k,m,n
  logical &
     weight
!
!  array arguments
  real &
     pv(n),res(n),sdpv(n),sdres(n),wt(n),xm(ixm,m),y(n)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     fplm
  integer &
     i,j
  character &
     string*20,fmt1*160,fmt2*160,fmt3*160
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     character*160 fmt1,fmt2,fmt3
!        the formats used to print the information.
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an indexing variable.
!     integer ierr
!        the integer value designating whether any errors have
!        been detected.
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected.
!     integer ifirst, ilast
!        the first and last indices to be listed.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the parameter being examined.
!     integer jcolm
!        the last column of the independent variable to be printed.
!     integer jcol1
!        the first column of the independent variable to be printed.
!     integer k
!        an index variable.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real res(n)
!        the residuals from the fit.
!     real sdpv(n)
!        the standard deviation of the predicted value.
!     real sdres(n)
!        the standard deviations of the residuals.
!     character*20 string
!        character string used to build the formats.
!     logical weight
!        the variable used to indicate whether weighted analysis is to
!        be performed (true) or not (false).
!     real wt(n)
!        the user supplied weights.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!     real y(n)
!        the array of the dependent variable.
!
  fplm = huge ( fplm )
!
!  construct format
!
  if (k == 1) then
     string = '1x,i4,15x,g15.8,15x,'
  else if (k == 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

  do i=ifirst, ilast

     if (mvchk(sdpv(i),fplm)) then
        if (weight) then
           write ( *, fmt1) i, (xm(i,j),j=jcol1,jcolm), &
                              y(i), pv(i), res(i), wt(i)
        else
           write ( *, 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 ( *, fmt2) i, (xm(i,j),j=jcol1,jcolm), &
                                 y(i), pv(i), sdpv(i), res(i), wt(i)
           else
              write ( *, fmt2) i, (xm(i,j),j=jcol1,jcolm), &
                                 y(i), pv(i), sdpv(i), res(i)
           end if
        else
           if (weight) then
              write ( *, fmt3) i, (xm(i,j),j=jcol1,jcolm), &
                                 y(i), pv(i), sdpv(i), res(i), &
                                 sdres(i), wt(i)
           else
              write ( *, fmt3) i, (xm(i,j),j=jcol1,jcolm), &
                                 y(i), pv(i), sdpv(i), res(i), &
                                 sdres(i)
           end if
        end if
     end if
  end do

  return

 1020 format ('(',a20,'2g16.8,8x,''nc *'',4x,g16.8,4x,''nc *'',1x,e9.3)')
 1030 format ('(',a20,'4g16.8,4x,''nc *'',1x,e9.3)')
 1040 format ('(',a20,'4g16.8,1x,f7.2,1x,e9.3)')
end
subroutine parchk ( iv, n, nn, p, v )

!***********************************************************************
!
!! PARCHK checks the NL2SOL parameters.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
  implicit none

  real, save :: big = 0.0E+00
  character ( len = 4 ) cngd(3)
  character ( len = 4 ) dflt(3)
  integer i
  integer iv(*)
  integer iv1
  integer jtolp
  integer k
  integer l
  integer m
  real machep
  integer n
  integer nn
  integer, parameter :: nvdflt = 27
  integer p
  integer, parameter :: parsv1 = 51
  integer, parameter :: prunit = 21
  integer pu
  real, save :: teensy = 1.0E+00
  real v(*)
  real vk
  real vm(27)
  character ( len = 8 ) vn(27)
  real vx(27)
  character ( len = 4 ) which(3)
!
! iv and v subscripts
!
      integer dtype, dtype0, d0init, epslon, inits, jtinit, jtol0, &
              jtol1, oldn, oldnn, oldp, parprt

     parameter (dtype=16, dtype0=29, d0init=37, epslon=19 )
     parameter ( inits=25, jtinit=39, jtol0=86, jtol1=87 )
     parameter ( oldn=45, oldnn=46, oldp=47, parprt=20 )

  data vn / &
    'epslon..', 'phmnfc..', 'phmxfc..', 'decfac..', 'incfac..', &
    'rdfcmn..', 'rdfcmx..', 'tuner1..', 'tuner2..', 'tuner3..', &
    'tuner4..', 'tuner5..', 'afctol..', 'rfctol..', 'xctol...', &
    'xftol...', 'lmax0...', 'dltfdj..', 'd0init..', 'dinit...', &
    'jtinit..', 'dltfdc..', 'dfac....', 'rlimit..', 'cosmin..', &
    'delta0..', 'fuzz....' /

      data vm(1)/1.0e-3/, vm(2)/-0.99e+0/, vm(3)/1.0e-3/, vm(4)/1.0e-2/, &
           vm(5)/1.2e+0/, vm(6)/1.e-2/, vm(7)/1.2e+0/, vm(8)/0.e+0/, &
           vm(9)/0.e+0/, vm(10)/1.e-3/, vm(11)/-1.e+0/, vm(15)/0.e+0/, &
           vm(16)/0.e+0/, vm(19)/0.e+0/, vm(20)/-10.e+0/, vm(21)/0.e+0/, &
           vm(23)/0.e+0/, vm(24)/1.e+10/, vm(27)/1.01e+0/
      data vx(1)/0.9e+0/, vx(2)/-1.e-3/, vx(3)/1.e+1/, vx(4)/0.8e+0/, &
           vx(5)/1.e+2/, vx(6)/0.8e+0/, vx(7)/1.e+2/, vx(8)/0.5e+0/, &
           vx(9)/0.5e+0/, vx(10)/1.e+0/, vx(11)/1.e+0/, vx(14)/0.1e+0/, &
           vx(15)/1.e+0/, vx(16)/1.e+0/, vx(18)/1.e+0/, vx(22)/1.e+0/, &
           vx(23)/1.e+0/, vx(25)/1.e+0/, vx(26)/1.e+0/, vx(27)/1.e+2/

     data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/
     data dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/

  if ( iv(1) == 0 ) then
    call dfault ( iv, v )
  end if

  pu = iv(prunit)
  iv1 = iv(1)

  if ( iv1 == 12 ) then

    if ( nn < n .or. n < p .or. p < 1 ) then
      iv(1) = 16
      if ( pu /= 0 ) then
        write ( pu, '(a)' ) ' '
        write ( pu, '(a)' ) '  Bad NN, N or P:'
        write ( pu, '(a)' ) ' '
        write ( pu, '(a,i5)' ) '  NN = ', nn
        write ( pu, '(a,i5)' ) '  N =  ', n
        write ( pu, '(a,i5)' ) '  P =  ', p
      end if
      return
    end if

    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
    which(1) = dflt(1)
    which(2) = dflt(2)
    which(3) = dflt(3)

  else

    if ( n  /= iv(oldn)  .or. &
         nn /= iv(oldnn) .or. &
         p  /= iv(oldp) ) then

      iv(1) = 17

      if ( pu /= 0 ) then
        write ( pu, '(a)' ) ' '
        write ( pu, '(a)' ) '(NN,N,P) changed from:'
        write ( pu, '(a,i8)' ) '  NN = ', iv(oldnn)
        write ( pu, '(a,i8)' ) '  N =  ', iv(oldn)
        write ( pu, '(a,i8)' ) '  P =  ', iv(oldp)
        write ( pu, '(a)' ) ' to:'
        write ( pu, '(a,i8)' ) '  NN = ', nn
        write ( pu, '(a,i8)' ) '  N =  ', n
        write ( pu, '(a,i8)' ) '  P =  ', p
      end if

      return

    end if

    if ( iv1 < 1 .or. 11 < iv1 ) then
      iv(1) = 50
      if ( pu /= 0 ) then
        write(pu,60) iv1
      end if
 60   format('  iv(1) =', i5, ' should be between 0 and 12.')
      return
    end if

    which(1) = cngd(1)
    which(2) = cngd(2)
    which(3) = cngd(3)

  end if

  if ( big <= teensy ) then
    teensy = tiny ( teensy )
    machep = epsilon ( machep )
    big = huge ( big )
    vm(12) = machep
    vx(12) = big
    vm(13) = teensy
    vx(13) = big
    vm(14) = machep
    vm(17) = teensy
    vx(17) = big
    vm(18) = machep
    vx(19) = big
    vx(20) = big
    vx(21) = big
    vm(22) = machep
    vx(24) = sqrt ( 0.999E+00 * huge ( vx(24) ) )
    vm(25) = machep
    vm(26) = machep
  end if

  m = 0

  if ( 0 <= iv(inits) .and. iv(inits) <= 2 ) then
    go to 110
  end if

         m = 18
         if (pu /= 0 ) then
           write(pu,100) iv(inits)
         end if

 100     format('inits... iv(25) =',i4,' should be between 0 and 2.')
 110 continue

  k = epslon

  do i = 1, nvdflt

    vk = v(k)

    if ( vm(i) <= vk .and. vk <= vx(i) ) then
      go to 130
    end if

      m = k
      if ( pu /= 0 ) then
        write(pu,120) vn(i), k, vk, vm(i), vx(i)
      end if

120   format( a8, '.. v(',i2, ') =', e11.3, &
      ' should be between ',e11.3, ' and', d11.3 )
130 continue
    k = k + 1

  end do
!
!  Check JTOL values.
!
  if ( iv1 /= 12 .or. v(jtinit) <= 0.0E+00 ) then

    jtolp = jtol0 + p
    do i = jtol1, jtolp
      if ( v(i) <= 0.0E+00 ) then
        k = i - jtol0
        if ( pu /= 0 ) then
          write(pu,150) k, i, v(i)
        end if
 150    format( 'jtol(', i3, ') = v(', i3, ') =', e11.3, &
                ' should be positive.' )
        m = i
      end if
    end do

  end if

  if ( m /= 0 ) then
    iv(1) = m
    return
  end if

!180  continue

  if ( pu == 0 .or. iv(parprt) == 0 ) then
    return
  end if

  if ( iv1 == 12 .and. iv(inits) /= 0 ) then
    m = 1
    write(pu,190) iv(inits)
190 format( 'nondefault values....inits..... iv(25) =', i3)
  end if

  if ( iv(dtype) /= iv(dtype0) ) then
    if ( m == 0 ) then
      write(pu,215) which
    end if
    m = 1
    write ( pu, '(a,i3)' ) 'DTYPE..... IV(16) = ', iv(dtype)
  end if

  k = epslon
  l = parsv1

  do i = 1, nvdflt

    if ( v(k) /= v(l) ) then
      if ( m == 0 ) then
        write(pu,215) which
      end if
 215  format(3a4,'alues....')
      m = 1
      write(pu,220) vn(i), k, v(k)
 220  format(1x,a8,'.. v(',i2,') =',e15.7)
    end if

    k = k + 1
    l = l + 1

  end do

  iv(dtype0) = iv(dtype)
  v(parsv1:parsv1+nvdflt-1) = v(epslon:epslon+nvdflt-1)

  if ( iv1 /= 12 ) then
    return
  end if

  if ( v(jtinit) <= 0.0E+00 ) then
    write ( pu, '(a)' ) '(Initial) JTOL array'
    write ( pu, '(6e12.3)' ) v(jtol1:jtol0+p)
  end if

  if ( v(d0init) <= 0.0E+00 ) then
    k = jtol1 + p
    write ( pu, '(a)' ) '(Initial) D0 array'
    write ( pu, '(6e12.3)' ) v(k:k+p-1)
  end if

  return
end
subroutine parzen ( lag, w, lw )

!*****************************************************************************80
!
!! PARZEN computes and stores the Parzen lag window.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer k
!        an index variable
!     integer l
!        the value lag/2.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lw
!        the length of the vector w.
!     real w(lw)
!        the vector of lag windows.
!
  implicit none

  integer lw

  integer k
  integer l
  integer lag
  real w(lw)

  l = lag/2
  w(1) = 1.0e0

  do 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)
  end do

  l = l + 1
  do 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)
  end do

  return
end
subroutine pgmest ( yfft, nfft, nf, cnst, per, lper )

!*****************************************************************************80
!
!! PGMEST computes the periodogram estimates.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real cnst
!        the variance of the observed time series times the number of
!        observations in the series if called by ipgm,
!        or 1.0e0 if called by pgm.
!     real fac
!        a factor used for computations of the integrated periodogram.
!     integer i
!        an index variable
!     integer isn
!        a code used for the fft.
!     integer lper
!        the length of the periodogram array.
!     integer nf
!        the number of frequencies at which the periodogram is
!        computed.
!     integer nfft
!        the effective number of observations for the fft transform.
!     integer nfft2
!        the effective number of complex observations for the fft
!        transform.
!     real per(lper)
!        the periodogram.
!     real yfft(nfft)
!        the centered series.
!
  implicit none

  real &
     cnst
  integer &
     lper,nf,nfft
!
!  array arguments
  real &
     per(lper),yfft(nfft)

  real &
     fac
  integer &
     i,isn,nfft2
!
!  external subroutines
  external fft,realtr
!
!  compute the Fourier coefficients
!
  nfft2 = (nfft-2) / 2
  isn = 2

  call fft (yfft(1), yfft(2), nfft2, nfft2, nfft2, isn)
  call realtr (yfft(1), yfft(2), nfft2, isn)

  fac = 0.5e0 / (cnst * real ( nfft - 2 ) )

  nf = nfft2 + 1

  do i = 1, nf
     per(i) = (yfft(2*i-1)*yfft(2*i-1) + yfft(2*i)*yfft(2*i)) * fac
  end do

  return
end
subroutine pgm ( yfft, n, lyfft, ldstak )

!*****************************************************************************80
!
!! PGM is the user callable routine for the raw periodogram of a series.
!
!  Discussion:
!
!    This is the short call version.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ldstak,lyfft,n
!
!  array arguments
  real &
     yfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  integer &
     freq,iextnd,ldsmin,nall0,nf,nfft,nprt,yaxis
  logical &
     err01,err02,err03,head
!
!  local arrays
  real &
     rstak(12)
  character &
     llds(8)*1,llyfft(8)*1,ln(8)*1,nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external eisge,ldscmp,pgmmn,setesl,stkclr,stkset
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     logical err01, err02, err03
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     integer freq
!        the starting location in the stack for
!        the array in which the frequencies corresponding to the
!        integrated spectrum values are stored.
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer iextnd
!        the indicator variable used to designate whether zero
!        (iextnd == 0) or the series mean (iextnd  /=  0) is to be
!        used to extend the series.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     character*1 llds(8), llyfft(8), ln(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations.
!     integer nall0
!        the number of outstanding allocations of the stack at the
!        time of this call.
!     integer nf
!        the number of frequencies at which the periodgram is
!        to be computed.
!     integer nfft
!        the effective length of the series to be transformed.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        the variable controling printed output, where
!        if nprt <= -2, the output consists of a page plot of the
!                         periodogram on a log-linear scale,
!        if nprt == -1, the output consists of a page plot of the
!                         periodogram in decibels on a linear scale,
!        if nprt ==  0, the output is suppressed,
!        if nprt ==  1, the output consists of a vertical plot of the
!                         periodogram in decibels on a linear scale.
!        if nprt  >=   2, the output consists of a vertical plot of the
!                         periodogram on a log-linear scale,
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     integer yaxis
!        the starting location in the stack for
!        the array in which the y axis values to be plotted are stored.
!     real yfft(lyfft)
!        the array containing the observed time series.
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  if (err01) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set length of extended series
!
  call setesl(n, 2, nfft)

  call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err02, llyfft)

  call ldscmp(2, 0, 0, 0, 0, 0, 's', nfft, ldsmin)

  call eisge(nmsub, llds, ldstak, ldsmin, 2, head, err03, llds)

  if (err01 .or. err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  set the size of the work area
!
  call stkset(ldstak, 4)
!
!  set the number of outstanding allocations.
!
  nall0 = stkst(1)

  nprt = -1
  iextnd = 0
!
!  subdivide the work array
!
  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)

  call stkclr(nall0)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call pgm (yfft, n, lyfft, ldstak)')
end
subroutine pgmmn ( yfft, n, nfft, iextnd, nf, per, lper, yaxis, &
     freq, lfreq, nprt, nmsub )

!*****************************************************************************80
!
!! PGMMN is the main routine for computing the raw periodogram.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iextnd,lfreq,lper,n,nf,nfft,nprt
!
!  array arguments
  real &
     freq(lfreq),per(lper),yaxis(lfreq),yfft(nfft)
  character &
     nmsub(6)*1

  real &
     yextnd
  integer n1
!
!  external subroutines
  external amean,pgmest,pgord,pgout,setfrq
!
!     variable definitions (alphabetically)
!
!     real freq(lfreq)
!        the array in which the frequencies corresponding to the
!        integrated spectrum values are stored.
!     integer i
!        an index variable.
!     integer iextnd
!        the indicator variable used to designate whether zero
!        (iextnd == 0) or the series mean (iextnd  /=  0) is to be
!        used to extend the series.
!     integer lfreq
!        the length of the array freq.
!     integer lper
!        the length of the array per.
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the periodgram is
!        to be computed.
!     integer nfft
!        the effective length of the series to be transformed.
!     character*1 nmsub(6)
!        the name of the calling subroutine
!     integer nprt
!        the variable controling printed output, where
!        if nprt <= -2, the output consists of a page plot of the
!                         periodogram on a log-linear scale,
!        if nprt == -1, the output consists of a page plot of the
!                         periodogram in decibels on a linear scale,
!        if nprt ==  0, the output is suppressed,
!        if nprt ==  1, the output consists of a vertical plot of the
!                         periodogram in decibels on a linear scale.
!        if nprt  >=   2, the output consists of a vertical plot of the
!                         periodogram on a log-linear scale,
!     real per(lper)
!        the array in which the periodogram is stored.
!     real yaxis(lfreq)
!        the array in which the y axis values to be plotted are stored.
!     real yextnd
!        the value used to extend the series.
!     real yfft(nfft)
!        the array containing the observed time series.
!
  yextnd = 0.0e0
  if (iextnd  /=  0) call amean (yfft, n, yextnd)
!
!  extend the periodogram array by its mean  or zero to the
!  extended length nfft.
!
  n1 = n + 1

  yfft(n1:nfft) = yextnd
!
!  compute the periodogram.
!
  call pgmest (yfft, nfft, nf, 1.0e0, per, lper)
!
!  set frequencies for periodogram values
!
  call setfrq (freq, nf, 1, 0.0e0, 0.5e0, 1.0e0)

  if (nprt == 0) return
!
!  set y coordinates for periodogram plot.
!
  call pgord (per, nf, yaxis, nprt)
!
!  plot periodogram if output not suppressed
!
  call pgout (yaxis, freq, nf, nprt, nmsub)

  return
end
subroutine pgms ( yfft, n, nfft, lyfft, iextnd, nf, per, lper, &
     freq, lfreq, nprt )

!*****************************************************************************80
!
!! PGMS computes the (raw) periodogram of a series (long call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     iextnd,lfreq,lper,lyfft,n,nf,nfft,nprt
!
!  array arguments
  real &
     freq(*),per(*),yfft(*)
!
!  scalars in common
  integer &
     ierr

  integer &
     nfft2
  logical &
     err01,err02,err03,err04,err05,head
!
!  local arrays
  character &
     llfreq(8)*1,llper(8)*1,llyfft(8)*1,ln(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,pgmmn
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01, err02, err03, err04, err05
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real freq(lfreq)
!        the array in which the frequencies corresponding to the
!        integrated spectrum values are stored.
!     logical head
!        a variable used to indicate whether a heading is needed for
!        error messages (true) or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer iextnd
!        the indicator variable used to designate whether zero
!        (iextnd == 0) or the series mean (iextnd  /=  0) is to be
!        used to extend the series.
!     integer lfreq
!        the length of the array freq.
!     character*1 llfreq(8), llper(8), llyfft(8), ln(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer lper
!        the length of the array per.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations.
!     integer nf
!        the number of frequencies at which the periodgram is
!        to be computed.
!     integer nfft
!        the effective length of the series to be transformed.
!     integer nfft2
!        the effective series length actually used.
!     integer nprt
!        the variable controling printed output, where
!        if nprt <= -2, the output consists of a page plot of the
!                         periodogram on a log-linear scale,
!        if nprt == -1, the output consists of a page plot of the
!                         periodogram in decibels on a linear scale,
!        if nprt ==  0, the output is suppressed,
!        if nprt ==  1, the output consists of a vertical plot of the
!                         periodogram in decibels on a linear scale.
!        if nprt  >=   2, the output consists of a vertical plot of the
!                         periodogram on a log-linear scale,
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     real per(lper)
!        the array in which the periodogram is stored.
!     real yfft(lyfft)
!        the array containing the observed time series.
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge ( nmsub, ln, n, 17, 1, head, err01, ln )

  if ( err01 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call enfft ( nmsub, nfft, 2, n, lyfft, nfft2, head, err02 )
  nf = nfft2 / 2

  call eisge(nmsub, llyfft, lyfft, nfft2, 9, head, err03, llyfft)

  call eisge(nmsub, llper, lper, nf, 9, head, err04, llper)

  call eisge(nmsub, llfreq, lfreq, nf, 9, head, err05, llfreq)

  if (err02 .or. err03 .or. err04 .or. err05) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call pgmmn (yfft, n, nfft2, iextnd, nf, per, lper, yfft, freq, &
     lfreq, nprt, nmsub)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call pgms (yfft, n, nfft, lyfft,'/ &
    '      +           iextnd, nf, per, lper, freq, lfreq, nprt)')
end
subroutine pgord ( per, npts, yaxis, nprt )

!*****************************************************************************80
!
!! PGORD produces coordinates for the periodogram plot.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     nprt,npts
!
!  array arguments
  real &
     per(npts),yaxis(npts)
!
!
  real &
     fplm
  integer &
     i
!
!     variable definitions (alphabetically)
!
!     real fplm
!        the floating point largest magnitude.
!     integer i
!        an index variable
!     integer nprt
!        the variable controling printed output, where
!        if nprt <= -2, the output consists of a page plot of the
!                         periodogram on a log-linear scale,
!        if nprt == -1, the output consists of a page plot of the
!                         periodogram in decibels on a linear scale,
!        if nprt ==  0, the output is suppressed,
!        if nprt ==  1, the output consists of a vertical plot of the
!                         periodogram in decibels on a linear scale.
!        if nprt  >=   2, the output consists of a vertical plot of the
!                         periodogram on a log-linear scale,
!     integer npts
!        the number of frequencies for which the spectral estimates
!        are estimated.
!     real per(npts)
!        the array containing the periodogram values.
!     real yaxis(npts)
!        the y coordinates for the periodogram plots.
!
  fplm = huge ( fplm )
!
!  the first value should be zero, so no attempt is made to plot it.
!
  yaxis(1) = fplm

  do i = 2, npts
     yaxis(i) = fplm
     if ( 0.0 < per(i) ) then
        yaxis(i) = per(i)
        if (iabs(nprt) == 1) yaxis(i) = 10.0e0*log10(yaxis(i))
    end if
  end do

  return
end
subroutine pgout ( yaxis, xaxis, npts, nprt, nmsub )

!*****************************************************************************80
!
!! PGOUT produces the periodogram plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer nprt
  integer npts
!
!  array arguments
  real &
     xaxis(npts),yaxis(npts)
  character &
     nmsub(6)*1

  real &
     fplm,xmiss,xmn,xmx,ymn,ymx
  integer &
     ilog
  logical &
     error
!
!  local arrays
  real &
     ymiss(1)
  integer &
     isym(1)
!
!     variable definitions (alphabetically)
!
!     logical error
!       an error flag
!     real fplm
!        the floating point largest magnitude.
!     integer isym(1)
!        a dummy array for the page plots.
!     character*1 nmsub(6)
!        the name of the calling subroutine.
!     integer nprt
!        the variable controling printed output, where
!        if nprt <= -2, the output consists of a page plot of the
!                         periodogram on a log-linear scale,
!        if nprt == -1, the output consists of a page plot of the
!                         periodogram in decibels on a linear scale,
!        if nprt ==  0, the output is suppressed,
!        if nprt  >=   1, the output consists of a vertical plot of the
!                         periodogram in decibels on a linear scale.
!     integer npts
!        the number of x, y coordinates to be plotted.
!     real xaxis(npts)
!        the x coordinates for the page plots.
!     real xmiss
!        the value used to specify if the periodogram value was
!        less than or equal to zero.
!     real xmn, xmx
!        ...
!     real yaxis(npts)
!        the y coordinates for the spectral plots.
!     real ymiss(1)
!        the value used to specify if an periodogram value was
!        less than or equal to zero.
!     real ymn, ymx
!
  fplm = huge ( fplm )

  xmiss = fplm
  ymiss(1) = fplm
!
!  set output width.
!


  call versp(.true.)
  if (iabs(nprt) == 1) then
     write ( *, 1010)
  else
     write ( *, 1000)
  end if

  if (abs(nprt) == 1) then
    ilog = 0
  else
    ilog = 1
  end if
!
!  Plot vertical plots
!
  if (nprt >= 1) then

    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/real(npts-1), 0.5e0 / real ( npts-1 ), &
     .true., ilog, -1, 0)
  else
!
!  Plot page plots
!
    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 ( *, 1030)
    end if
  end if

  return

 1000 format (' sample periodogram')
 1010 format (' sample periodogram (in decibels)')
 1030 format ('+freq'/ &
     ' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, '6.6667', 4x, &
     '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, '2.5', 7x, &
     '2.2222', 4x, '2.')

end
subroutine pline ( imin, imax, isymbl, line )

!*****************************************************************************80
!
!! PLINE defines one line of a plot string for the vertical plot routines.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer imax
!        the largest location in the plot string being defined.
!     integer imin
!        the smallest location in the plot string being defined.
!     character*1 isymbl
!        the plotting symbol being used.
!     character*1 line(103)
!        the vector used for the plot string.
!
  implicit none

  integer &
     imax,imin
  character &
     isymbl*1
!
!  array arguments
  character &
     line(103)*1

  line(imin:imax) = isymbl

  return
end
subroutine pltchk ( ym, ymmiss, x, xmiss, n, m, iym, multi, &
     ilog, ylb, yub, xlb, xub, nmsub, miss, xcheck )

!*****************************************************************************80
!
!! PLTCHK checks for errors for the multiple plot routines.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,iym,m,n
  logical &
     miss,multi,xcheck
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     nv
  logical &
     err01,err02,err03,err04,err05,err06,err07,err08,err09,head
!
!  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
!
!  external subroutines
  external eisge,eragt,eragtm,ersgt,ervgt,ervgtm,prtcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01, err02, err03, err04, err05, err06, err07, err08,
!    1   err09
!        values indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the common variable used as an error flag
!        if = 0 then no erorrs
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ilogxy(2)
!        ...
!     integer iym
!        actual row dimension of ym declared in users main program
!     character*1 liym(8), lm(8), ln(8), lone(8), lx(8), lxlb(8),
!    *  lxub(8), ly(8), lylb(8), lym(8), lyub(8)
!        the array(s) containing the name(s) of the input parameters(s)
!        checked for errors.
!     integer m
!        the number of vectors in ym
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        an indicator variable used to designate whether the calling
!        routine has an m prefix (true) or not (false).
!     integer n
!        the length of the vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nv
!        the number of violations found in the x and y axis arrays.
!     real x(n)
!        vector of observations for x coordinates
!     logical xcheck
!        indicator variable used to designate whether x-axis values
!        are to be checked (xcheck = .true.) or not (xcheck = .false.)
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        multivariate observations for the y (vertical) coordinates.
!     real ymmiss(m)
!        the missing value code for each column of ym.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  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) &
     /     ' ',     ' '/

  ierr = 0
  head = .true.
!
!  number of points must be at least 1
!
  call eisge(nmsub, ln, n, 1, 2, head, err01, lone)
!
!  there must be at least 1 column of vectors
!
  call eisge(nmsub, lm, m, 1, 2, head, err02, lone)
!
!  the actual length of ym must equal or exceed the number of
!  observations
!
  err03 = .true.
  if (.not.err01) &
     call eisge(nmsub, liym, iym, n, 3, head, err03, ln)
!
!  if this is a log plot check for non-positive values in data
!
  if (err01 .or. err02 .or. err03) ierr = 1
  if (ilog <= 0) return

  err04 = .false.
  err05 = .false.
  err06 = .false.
  err07 = .false.
  err08 = .false.
  err09 = .false.

  call prtcnt (max(0,ilog),2,ilogxy)
  if ((ilogxy(1) /= 0) .and. xcheck) then
    if (.not.err01) then
!
!  if x axis is log scale, check for negative x axis values
!
      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

    if (xlb<xub) then
!
!  check for negative plot bounds
!
      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) /= 0) then
    if ((.not.err01) .and. (.not.err02) .and. (.not.err03)) then
!
!  if y ayis is log scale, check for negative y ayis values
!
      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

    if (ylb<yub) then
!
!  check for negative plot bounds
!
      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

  if (err04 .or. err05 .or. err06 .or. err07 .or. err08 .or. err09) &
     ierr = 1

  return
end
subroutine pltplx ( point, ymn, scale, ipoint, iend )

!*****************************************************************************80
!
!! PLTPLX computes the point location in the plot string.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iend
!        the number of locations in the plot string.
!     integer ipoint
!        the location in the plot string of the value being plotted.
!     real point
!        the value to be plotted.
!     real scale
!        the scale interval of the plot.
!     real ymn
!        the graph axis lower limits actually used.
!
  implicit none

  real &
     point,scale,ymn
  integer &
     iend,ipoint

  ipoint = int ( ( point - ymn ) / scale + 2.5 )
  if (ipoint < 2) ipoint = 1
  if (ipoint > iend) ipoint = iend

  return
end
subroutine pltsym ( iptsym, i, j, isym, n, ipoint, line, icount )

!*****************************************************************************80
!
!! PLTSYM supplies the plot symbol for the plot line.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an indexing variable.
!     integer icount(103)
!        the number of plot symbols at each location.
!     integer ipoint
!        the location in the plot string of the value being plotted.
!     integer iptsym
!        an indicator variable used to designate the type
!        of plot.  if iptsym = 1, the plot is a symple page
!        or vertical plot.  if iptsym = 2, the plot is a symbol
!        plot.  if iptsym = 3, the plot is a multivariate plot.
!     integer isym(n)
!        vector containing symbol designations for plotting
!     integer isymbl
!        the index of the plot symbol to be used.
!     integer j
!        an index variable.
!     character*1 line(103)
!        the vector used for the plot string.
!     integer n
!        the number of observations.
!     character*1 sym(30), sym1(10)
!        the plot symbols.
!
  implicit none

  integer &
     i,ipoint,iptsym,j,n
!
!  array arguments
  integer &
     icount(103),isym(n)
  character &
     line(103)*1
!
!
  integer &
     isymbl
!
!  local arrays
  character &
     sym(30)*1,sym1(10)*1

  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'/

  icount(ipoint) = icount(ipoint) + 1

  if ( icount(ipoint) /= 1 ) then
    isymbl = min(icount(ipoint), 10)
    line(ipoint) = sym1(isymbl)
    return
  end if

  if ( iptsym == 1 ) then
    line(ipoint) = sym(1)
  else if ( iptsym == 2 ) then
    isymbl = min(29, max(1, isym(i)))
    line(ipoint) = sym(isymbl)
  else if ( iptsym == 3 ) then
    isymbl = min(29, max(1, j+4))
    line(ipoint) = sym(isymbl)
  end if

  return
end
subroutine polar ( ampl, phas, n )

!*****************************************************************************80
!
!! POLAR converts complex numbers from Cartesian to polar representation.
!
!  Discussion:
!
!    This routine converts the pair of series ampl and phas
!    from the real and imaginary parts of a series of complex
!    numbers to their magnitudes and phases.  the conversion is
!    done in place.
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
!  Parameters:
!
!     real ampl(n)
!        the array in which the amplitudes are stored.
!     integer i
!        an index variable.
!     integer n
!        the number of observations.
!     real phas(n)
!        the array in which the primary phase estimates are returned.
!     real phase
!        the phase component of the demodulated series.
!     real r
!        the amplitude component of the demodulated series.
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     ampl(n),phas(n)
!
!
  real &
     phase,r
  integer &
     i

  do i = 1, n
     r = sqrt(ampl(i)*ampl(i) + phas(i)*phas(i))
     phase = 0.0e0
     if (r  /=  0.0e0) phase = atan2(phas(i), ampl(i))
     ampl(i) = r
     phas(i) = phase
  end do

  return
end
subroutine ppc ( ym, x, n, ilog, isize, nout, ylb, yub, xlb, xub )

!*****************************************************************************80
!
!! PPC produces a simple page plot (long call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xlb,xub,ylb,yub
  integer &
     ilog,isize,n,nout
!
!  array arguments
  real &
     x(*),ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xmiss
  integer &
     ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'p',       'p',       'c',       ' ',       ' ',       ' '/

  ymmiss(1) = 1.0e0
  xmiss = 1.0e0
  m = 1
  iym = n
  multi = .false.
  ischck = 0
  miss = .false.
  lisym = 1

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ppc (y, x, n, ilog,'/ &
     '      +          isize, nout, ylb, yub, xlb, xub)')
end
subroutine ppcnt ( ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym )

!*****************************************************************************80
!
!! PPCNT is the controling routine for user called page plot routines.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,ischck,isize,iym,lisym,m,n,nout
  logical &
     miss,multi
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(*)
  integer &
     isym(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xmn,xmx,ymn,ymx
  logical &
     error,xcheck
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical error
!        a value indicating whether an error was detectec (true)
!        or not (false).
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(lisym)
!        vector containing symbols for plotting, not used in some cases
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     logical xcheck
!        indicator variable used to designate whether x-axis values
!        are to be checked (xcheck = .true.) or not (xcheck = .false.)
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xmn, xmx
!        the x-axis lower and upper limits actually used.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        vector of observations for the y (vertical) coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real ymn, ymx
!        the y-ayis lower and upper limits actually used.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
  xcheck = .true.
  call pltchk (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
     ylb, yub, xlb, xub, nmsub, miss, xcheck)

  if (ierr == 0) then
!
!  determine the bounds for the x and y axis and complete error
!  checking
!
    call pplmt (ym, ymmiss, x, xmiss, n, m, iym, ylb, yub, ymn, ymx, &
      xlb, xub, xmn, xmx, error, nmsub, miss)

    if (error) then
      ierr = 1
    else
!
!  Print plot
!
    if (isize <= 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)

    end if
  end if

  return
end
subroutine pp ( ym, x, n )

!*****************************************************************************80
!
!! PP: user callable routine which produces a simple page plot (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     x(*),ym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'p',       'p',       ' ',       ' ',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call pp (y, x, n)')
end
function ppfchs ( p, nu )

!*****************************************************************************80
!
!! PPCHFS computes the percentage points of the Chi Square distribution.
!
!  Discussion:
!
!    This function is a version of datapac subroutine chsppf, with
!    modifications to facilitate conversion to double precision
!    automatically using the nag, inc., code apt, and to correspond
!    to starpac conventions.
!
!    This routine computes the percent point
!    function value for the chi-squared distribution
!    with integer degrees of freedom parameter = nu.
!    the chi-squared distribution used
!    herein is defined for all non-negative x,
!    and its probability density function is given
!    in references 2, 3, and 4 below.
!    note that the percent point function of a distribution
!    is identically the same as the inverse cumulative
!    distribution function of the distribution.
!
!  Author:
!
!    James Filliben,
!    Statistical Engineering Laboratory,
!    National Bureau of Standards,
!    Washington, DC 20234.
!
!  Reference:
!
!    Formula 6.1.41,
!    Milton Abramowitz, Irene Stegun,<br>
!    Handbook of Mathematical Functions,<br>
!    National Bureau of Standards, 1964,<br>
!    LC: QA47.A34,<br>
!    ISBN: 0-486-61272-4.
!
!    Johnson, Kotz,
!    Continuous Univariate Distributions,
!    1970, pages 166-206.
!
!    Wilk, Gnanadesikan, Huyett, 
!    Probability Plots for the Gamma Distribution",
!    Technometrics, 1962
!.
!    Hastings, Peacock, 
!    Statistical Distributions,
!    A Handbook for Students and Practitioners, 
!    1975, pages 46-51.
!
!     input  arguments--p      = the single precision value
!                                (between 0.0e0 (inclusively)
!                                and 1.0e0 (exclusively))
!                                at which the percent point
!                                function is to be evaluated.
!                     --nu     = the integer number of degrees
!                                of freedom.
!                                nu should be positive.
!     output arguments--ppfchs = the single precision percent
!                                point function value.
!
!     restrictions--nu should be a positive integer variable.
!                 --p should be between 0.0e0 (inclusively)
!                   and 1.0e0 (exclusively).
!
!     accuracy--(on the univac 1108, exec 8 system at nbs)
!               compared to the known nu = 2 (exponential)
!               results, agreement was had out to 6 significant
!               digits for all tested p in the range p = .001 to
!               p = .999.  for p = .95 and smaller, the agreement
!               was even better--7 significant digits.
!               (note that the tabulated values given in the wilk,
!               gnanadesikan, and huyett reference below, page 20,
!               are in error for at least the gamma = 1 case--
!               the worst detected error was agreement to only 3
!               significant digits (in their 8 significant digit table)
!               for p = .999.)
  implicit none

  integer nu
  real p
  real ppfchs

  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,j,maxit
!
!  local arrays
  real &
     d(10)

  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/

  d(1) = 1.0e0/12.0e0
  d(2) = 1.0e0/360.0e0

  if ( p < 0.0E+00 .or. 1.0E+00 <= p ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'PPFCHS - Fatal error!'
    write ( *, '(a)' ) '  The first input argument P is outside'
    write ( *, '(a)' ) '  the allowable (0,1) interval.'
    write ( *, '(a,g14.6)' ) '  P = ', p
    ppfchs = 0.0e0
    return
  end if

  if(nu<1) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'PPFCHS - Fatal error!'
    write ( *, '(a)' ) '  The second input argument NU is not positive.'
    write ( *, '(a,i8)' ) '  NU = ', nu
    ppfchs = 0.0e0
    return
  end if
!
!  Express the chi-squared distribution percent point
!  function in terms of the equivalent gamma
!  distribution percent point function,
!  and then evaluate the latter.
!
  fp = p
  gamma = real ( nu ) / 2.0e0
  maxit = 10000
!
!  Compute the Gamma function using the algorithm in the
!  NBS applied mathematics series reference.
!  This Gamma function need be calculated only once.
!  It is used in the calculation of the cdf based on
!  the tentative value of the ppfchs in the iteration.
!
  z = gamma
  den = 1.0e0

  do

    if ( 10.0 <= z ) then
      exit
    end if

    den = den * z
    z = z + 1.0e0

  end do

  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)
!
!  Determine lower and upper limits on the desired 100p percent point.
!
  iloop = 1
  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 = real ( icount ) * xmin0
  dx = xmax
  go to 600

  360 if(pcalc<fp) then
     xmin = xmax
     icount = icount+1
     if(icount <= 30000) go to 350
  end if

  xmid = (xmin+xmax)/2.0e0
!
!  Iterate by bisection until the desired accuracy is achieved.
!
  iloop = 2
  xlower = xmin
  xupper = xmax
  icount = 0

  550 dx = xmid
  go to 600

  560 continue

  if(pcalc /= fp) then
     if(pcalc > fp) then
        xupper = xmid
        xmid = (xmid+xlower)/2.0e0
     else
        xlower = xmid
        xmid = (xmid+xupper)/2.0e0
     end if
     xdel = xmid-xlower
     if(xdel<0.0e0)xdel = -xdel
     icount = icount+1
     if((xdel >= 0.0000000001e0) .and. (icount <= 100)) go to 550
  end if

  ppfchs = 2.0e0*xmid
  return
!
!  this section below is logically separate from the above.
!  this section computes a cdf value for any given tentative
!  percent point x value as defined in either of the 2
!  iteration loops in the above code.
!
!  compute t-sub-q as defined on page 4 of the wilk, gnanadesikan,
!  and huyett reference
!
  600 continue

  sum = 1.0e0/gamma
  term = 1.0e0/gamma
  cut1 = dx-gamma
  cut2 = dx*10000000000.0e0

  do j=1,maxit
     aj = real ( j )
     term = dx*term/(gamma+aj)
     sum = sum+term
     cutoff = cut1+(cut2*term/sum)
     if (aj > cutoff) go to 750
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'PPFCHS - Fatal error!'
  write ( *, '(a)' ) '  The iteration did not converge.'
  write ( *, '(a,i8)' ) '  Iteration limit is MAXIT = ', maxit
  write ( *, '(a,g14.6)' ) '  P = ', p
  write ( *, '(a,i8)' ) '  NU = ', nu
  write ( *, '(a)' ) '  PPFCHS has been set to zero.'
  ppfchs = 0.0e0
  return

  750 continue
  pcalc = exp(gamma*log(dx) + log(sum) + log(den) - dx - a - b)
  if (iloop == 1) go to 360
  go to 560

end
function ppff ( p, nu1, nu2 )

!*****************************************************************************80
!
!! PPFF computes the percentage points for the F distribution.
!
!  Discussion:
!
!    This function is a version of dataplot subroutine fppf,
!    with modifications necessary to correspond to starpac conventions.
!
!    this subroutine computes the percent point for the f distribution
!    with integer degrees of freedom parameters = nu1 and nu2.
!
!    this distribution is defined for all non-negative x.
!    the probability density function is given in the reference.
!
!  Author:
!
!    James Filliben,
!    Statistical Engineering Laboratory,
!    National Bureau of Standards,
!    Washington, DC 20234.
!
!     input  arguments--p      = the single precision value
!                                (between 0.0e0 and 1.0e0)
!                                at which the percent point
!                                function is to be evaluated.
!                     --nu1    = the integer degrees of freedom
!                                for the numerator of the f ratio.
!                                nu1 should be positive.
!                     --nu2    = the integer degrees of freedom
!                                for the denominator of the f ratio.
!                                nu2 should be positive.
!     output arguments--ppff    = the single precision percent point
!                                function value.
!     output--the single precision percent point
!             function value ppff for the f distribution
!             with degrees of freedom
!             parameters = nu1 and nu2.
!
!     restrictions--p should be between
!                   0.0e0 (inclusively) and 1.0e0 (exclusively).
!                 --nu1 should be a positive integer variable.
!                 --nu2 should be a positive integer variable.
!
!  Reference:
!
!    national bureau of standards applied mathematics
!    series 55, 1964, pages 946-947,
!    formulae 26.6.4, 26.6.5, 26.6.8, and 26.6.15.
!
!    johnson and kotz, 
!    continuous univariate distributions--2,
!    1970, page 83, formula 20, and page 84, third formula.
!
!    paulson,
!    an approximate normailization of the analysis of variance distribution,
!    annals of mathematical statistics, 1942,
!    number 13, pages 233-135.
!
!    scheffe, tukey, 
!    a formula for sample sizes for population tolerance limits,
!    1944, number 15, page 217.
!
  implicit none

  real p
  real ppff
  integer &
     nu1,nu2
!
!
  real &
     anu1,anu2,expf,pcalc,sdf,tol,x,xdel,xlow,xmax, &
     xmid,xmin,xn,xup,zn
  integer &
     ibug,icount,maxit
!
!  external functions
  real &
     cdff,ppfnml
  external cdff,ppfnml
!
!     variable definitions (alphabetically)
!
!     real anu1
!        the (real) degrees of freedom in the numerator.
!     real anu2
!        the (real) degrees of freedom in the denominator.
!     integer nu1
!        the degrees of freedom in the numerator.
!     integer  nu2
!        the degrees of freedom in the denominator.
!     real p
!        the value (between 0.0e0 and 1.0e0) at which the percent point
!        is to be calculated.
!
  ppff = 0.0e0

  if ( nu1 <= 0 ) then
    write ( *,1010)
    write ( *,1040) nu1
    ppff = 0.0e0
    return
  end if

  if (nu2 <= 0) then
    write ( *,1020)
    write ( *,1040) nu2
    ppff = 0.0e0
    return
  end if

  if ( p < 0.0e0 .or. p >= 1.0e0) then
    write ( *,1000)
    write ( *,1030) p
    ppff = 0.0e0
    return
  end if

  ibug = 0.0e0

  tol = 0.000001e0
  maxit = 100
  xmin = 0.0e0
  xmax = 10.0e30
  xlow = xmin
  xup = xmax

  anu1 = real ( nu1 )
  anu2 = real ( nu2 )

  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 == 1) write ( *,1050) xmid

  if (p == 0.0e0) then
    ppff = xmin
    return
  end if

  icount = 0

   70 continue
  x = xmid
  pcalc = cdff(x,anu1,anu2)
  if (pcalc == p) go to 130

  if (pcalc > p) go to 100

   80 continue
  xlow = xmid
  x = xmid*2.0e0
  if (x >= xup) go to 90
  xmid = x
  if (ibug == 1) write ( *,1050) xmid
  pcalc = cdff(x,anu1,anu2)
  if (pcalc == p) go to 130
  if (pcalc<p) go to 80
  xup = x
   90 continue
  xmid = (xlow+xup)/2.0e0
  if (ibug == 1) write ( *,1050) xmid
  go to 120

  100 continue
  xup = xmid
  x = xmid/2.0e0
  if (x <= xlow) go to 110
  xmid = x
  if (ibug == 1) write ( *,1050) xmid
  pcalc = cdff(x,anu1,anu2)
  if (pcalc == p) go to 130
  if (pcalc > p) go to 100
  xlow = x
  110 continue
  xmid = (xlow+xup)/2.0e0
  if (ibug == 1) write ( *,1050) xmid

  120 continue
  xdel = abs(xmid-xlow)
  icount = icount + 1
  if (xdel<tol .or. icount > maxit) go to 130
  go to 70

  130 continue
  ppff = xmid

  return
 1000 format (' ***** fatal error--the first  input argument to t', &
     'he fppf subroutine is outside the allowable (0,1) interval ', &
     '*****')
 1010 format (' ***** fatal error--the second input argument to t', &
     'he fppf   subroutine is non-positive *****')
 1020 format (' ***** fatal error--the third  input argument to t', &
     'he fcdf   subroutine is non-positive *****')
 1030 format (' ***** the value of the argument is ', e15.8, &
     ' *****')
 1040 format (' ***** the value of the argument is ', i8, ' *****')
 1050 format (' ', 'xmid = ', e15.7)
end
function ppfnml ( p )

!*****************************************************************************80
!
!! PPFNML computes the percentage points of the normal distribution.
!
!  Discussion:
!
!    this subroutine computes the percent point function value for the 
!    normal (gaussian) distribution with mean = 0 and standard deviation = 1.
!
!    this distribution is defined for all x and has the probability density 
!    function
!
!      f(x) = (1/sqrt(2*pi))*exp(-x*x/2).
!
!    note that the percent point function of a distribution
!    is identically the same as the inverse cumulative
!    distribution function of the distribution.
!
!  Author:
!
!    James Filliben,
!    Statistical Engineering Laboratory,
!    National Bureau of Standards,
!    Washington, DC 20234.
!
!     restrictions--p should be between 0.0e0 and 1.0e0, exclusively.
!
!  Reference:
!
!    odeh, evans,
!    Algorithm 70:
!    the percentage points of the normal distribution,
!    applied statistics, 1974, pages 96-97.
!
!    evans,
!    algorithms for minimal degree polynomial and rational approximation,
!    m. sc. thesis, 1972,
!    university of victoria, b. c., canada.
!
!    hastings,
!    approximations for digital computers, 1955, pages 113, 191, 192.
!
!    national bureau of standards applied mathematics
!    series 55, 1964, page 933, formula 26.2.23.
!
!    filliben,
!    simple and robust linear estimation of the location parameter 
!    of a symmetric distribution 
!    pHD dissertation,
!    princeton university, 1969, pages 21-44, 229-231.
!
!    filliben, 
!    the percent point function,
!    unpublished manuscript, 1970, pages 28-31.
!
!    johnson and kotz,
!    continuous univariate distributions--1,
!    1970, pages 40-111.
!
!    the kelley statistical tables, 1948.
!
!    owen,
!    handbook of statistical tables,
!   1962, pages 3-16.
!
!    pearson and hartley,
!    biometrika tables for statisticians,
!    volume 1, 1954, pages 104-113.
!
!     comments--the coding as presented below
!               is essentially identical to that
!               presented by odeh and evans
!               as algortihm 70 of applied statistics.
!               the present author has modified the
!               original odeh and evans code with only
!               minor stylistic changes.
!             --as pointed out by odeh and evans
!               in applied statistics,
!               their algorithm representes a
!               substantial improvement over the
!               previously employed
!               hastings approximation for the
!               normal percent point function--
!               the accuracy of approximation
!               being improved from 4.5*(10**-4)
!               to 1.5*(10**-8).
!
  implicit none

  real  p
  real ppfnml
!
!
  real &
     aden,anum,p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,r,t
!
!     variable definitions (alphabetically)
!
!     real p
!        the probability at which the percent point is to be evaluated
!     real p0, p1, p2, p3, p4
!        various parameters used in the approximations.
!     real q0, q1, q2, q3, q4
!        various additional parameters used in the approximations.
!
  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/

  if (p == 0.5e0) then
    ppfnml = 0.0e0
    return
  end if

  r = p
  if (p > 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)

  if (p<0.5e0) then
    ppfnml = -ppfnml
  end if

  return
end
function ppft ( p, idf )

!*****************************************************************************80
!
!! PPFT computes the percentage points of the Student's T distribution.
!
!  Discussion:
!
!    this subroutine computes the percent point function value for the 
!    student"s t distribution with integer degrees of freedom parameter = idf.
!
!    the student"s t distribution used herein is defined for all x,
!    and its probability density function is given in the reference.
!
!    note that the percent point function of a distribution is identically 
!    the same as the inverse cumulative distribution function of the 
!    distribution.
!
!  Author:
!
!    James Filliben,
!    Statistical Engineering Laboratory,
!    National Bureau of Standards,
!    Washington, DC 20234.
!
!  Reference:
!
!    Enrico Federghi,
!    Extended Tables of the Percentage Points of Student's T-Distribution,
!    Journal of the American Statistical Association,
!    Volume 54, Number 287, 1959, pages 683-688.
!
!   national bureau of standards applied mathmatics
!                 series 55, 1964, page 949, formula 26.7.5.
!
!    johnson and kotz,
!    continuous univariate distributions--2, 1970, 
!    page 102, formula 11.
!
!    hastings and peacock,
!    statistical distributions--a handbook for students and practitioners, 
!    1975, pages 120-123.
!
!     restrictions--idf should be a positive integer variable.
!                 --p should be between 0.0e0 (exclusively)
!                   and 1.0e0 (exclusively).
!     comment--for idf = 1 and idf = 2, the percent point function
!              for the t distribution exists in simple closed form
!              and so the computed percent points are exact.
!            --for other small values of idf (idf between 3 and 6,
!              inclusively), the approximation
!              of the t percent point by the formula
!              given in the reference below is augmented
!              by 3 iterations of newton"s method for
!              root determination.
!              this improves the accuracy--especially for
!              values of p near 0 or 1.
!

!
  implicit none

  real p
  real ppft
  integer &
     idf

  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
!
!  external functions
  real &
     ppfnml
  external ppfnml
!
!  external subroutines
  external getpi
!
!     variable definitions (alphabetically)
!
!     real df
!        the degrees of freedom.
!     integer idf
!        the (integer) degrees of freedom.
!     real p
!        the probability at which the percent point is to be evaluated.
!     real pi
!        the value of pi.
!     real ppfn
!        the normal percent point value.
!     real sqrt2
!        the square root of two.
!
!  define constants used in the approximations
!
  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/

  call getpi(pi)

  sqrt2 = sqrt(2.0e0)

  df = real ( idf )
  maxit = 5

  if (idf >= 3) go to 50
  if (idf == 1) go to 30
  if (idf == 2) go to 40
  ppft = 0.0e0
  return
!
!  treat the idf = 1 (cauchy) case
!
   30 arg = pi*p
  ppft = -cos(arg)/sin(arg)
  return
!
!  treat the idf = 2 case
!
   40 term1 = sqrt2/2.0e0
  term2 = 2.0e0*p - 1.0e0
  term3 = sqrt(p*(1.0e0-p))
  ppft = term1*term2/term3
  return
!
!  treat the idf greater than or equal to 3 case
!
   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 >= 7) return
  if (idf == 3) go to 60
  if (idf == 4) go to 80
  if (idf == 5) go to 100
  if (idf == 6) go to 120
  return
!
!  augment the results for the idf = 3 case
!
   60 con = pi*(p-0.5e0)
  arg = ppft/sqrt(df)
  z = atan(arg)
  do ipass = 1, maxit
    s = sin(z)
    c = cos(z)
    z = z - (z+s*c-con)/(2.0e0*c*c)
  end do
  ppft = sqrt(df)*s/c
  return
!
!  augment the results for the idf = 4 case
!
   80 con = 2.0e0*(p-0.5e0)
  arg = ppft/sqrt(df)
  z = atan(arg)
  do ipass=1,maxit
     s = sin(z)
     c = cos(z)
     z = z - ((1.0e0+0.5e0*c*c)*s-con)/(1.5e0*c*c*c)
  end do
  ppft = sqrt(df)*s/c
  return
!
!  augment the results for the idf = 5 case
!
  100 con = pi*(p-0.5e0)
  arg = ppft/sqrt(df)
  z = atan(arg)

  do 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)
  end do

  ppft = sqrt(df)*s/c
  return
!
!  augment the results for the idf = 6 case
!
  120 con = 2.0e0*(p-0.5e0)
  arg = ppft/sqrt(df)
  z = atan(arg)

  do 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)
  end do

  ppft = sqrt ( df ) * s / c

  return
end
subroutine ppl ( ym, x, n, ilog )

!*****************************************************************************80
!
!! PPL produces a simple page plot (log option).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ilog,n
!
!  array arguments
  real &
     x(*),ym(*)
!
!  scalars in common
  integer &
     ierr

  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'p',       'p',       'l',       ' ',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ppl (y, x, n, ilog)')
end
subroutine pplmt ( ym, ymmiss, x, xmiss, n, m, iym, ylb, yub, ymn, &
  ymx, xlb, xub, xmn, xmx, error, nmsub, miss )

!*****************************************************************************80
!
!! PPLMT sets the plot limits for page plots with missing values.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real xlb
  real xmiss
  real xmn
  real xmx
  real xub
  real ylb
  real ymn
  real ymx
  real yub

  integer &
     iym,m,n
  logical &
     error,miss
!
!  array arguments
  real &
     x(n),ym(iym,m),ymmiss(m)
  character &
     nmsub(6)*1
!
!
  integer &
     i,ii,j
  logical &
     head,setlmt,skprow
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  external subroutines
  external adjlmt,ehdr
!
!     variable definitions (alphabetically)
!
!     logical error
!        a value indicating whether an error was detected (true)
!        or not (false).
!     logical head
!        print heading (head=true) or not (head=false).
!     integer i, ii
!        indexing variables.
!     integer iym
!        actual row dimension of ym declared in the users main program
!     integer j
!        an index variable.
!     integer m
!        the number of vectors in ym
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     integer n
!        the integer number of observations .
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     logical setlmt
!        an indicator variable used to determine if starting values
!        for xmn, xmx, ymn, ymx have been found.
!     logical skprow
!        an indicator variable used to designate whether all
!        observations in a given row of ym are unused (true)
!        or not (false).
!     real x(n)
!        the array containing the independent variable.
!     real xlb
!        the user supplied x-axis lower bound.
!     real xmiss
!        the user supplied code which is used to determine whether or
!        not an observation is missing.
!        if x(i) = xmiss, the value is assumed missing, otherwise
!        it is not.
!     real xmn, xmx
!        the x-axis lower and upper limits actually used.
!     real xub
!        the user supplied x-axis upper bounds.
!     real ylb
!        the user supplied y-axis lower bound.
!     real ym(iym,m)
!        the array containing the dependent variable(s).
!     real ymmiss(m)
!        the user supplied code which is used to determine whether or
!        not an observation is missing.
!        if ym(i,j) = ymmiss(j), the value is assumed missing, otherwise
!        it is not.
!     real ymn, ymx
!        the y-axis lower and upper limits actually used.
!     real yub
!        the user supplied y-axis upper bounds.
!
  error = .false.

  if ((xlb < xub) .and. (ylb < yub)) then
!
!  set limits to user specified values
!
    xmn = xlb
    xmx = xub
    ymn = ylb
    ymx = yub

  else
!
!  set limits to range of values within any user specified values
!
    setlmt = .false.
    ii = 1
    xmn =  huge ( xmn )
    xmx = -huge ( xmx )
    ymn =  huge ( ymn )
    ymx = -huge ( ymx )
!
!  find first value to be plotted
!
    do i=1,n

       if (miss .and. mvchk(x(i),xmiss)) then
         cycle
       end if

       if ((xlb<xub) .and. ((x(i)<xlb) .or. &
          (xub<x(i)))) then
         cycle
       end if

       xmn = x(i)
       xmx = x(i)

       do j=1,m

          if (miss .and. mvchk(ym(i,j),ymmiss(j))) then
            cycle
           end if

          if ((ylb<yub) .and. ((ym(i,j)<ylb) .or. &
             (yub<ym(i,j)))) then
            cycle
          end if

          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 + 1
          end if


       end do

       if (setlmt) then
         exit
       end if

   end do

   if (ii <= 1) then
!
!  no values to be plotted.  print error message
!
      error = .true.
      head = .true.
      call ehdr(nmsub,head)
      if ((ylb >= yub) .and. (xlb >= xub)) then
        write ( *, 1010)
      else
        write ( *, 1020)
      end if
      write ( *, 1030)

    else
!
!  find limits from remaining values
!
        do i=ii,n

          if ( miss .and. mvchk(x(i),xmiss) ) then
            cycle
          end if

          if ((xlb<xub) .and. ((x(i)<xlb) .or. &
              (xub<x(i)))) then
            cycle
          end if

           skprow = .true.

           do j=1,m

              if (miss .and. mvchk(ym(i,j),ymmiss(j))) then
                cycle
              end if

              if ((ylb<yub) .and. ((ym(i,j)<ylb) .or. &
                 (yub<ym(i,j)))) then
                cycle
              end if

              skprow = .false.
              ymn = min(ymn, ym(i,j))
              ymx = max(ymx, ym(i,j))

           end do

           if ( .not. skprow ) then
             xmn = min(xmn, x(i))
             xmx = max(xmx, x(i))
           end if

        end do

    end if

    if (ylb<yub) then
!
!  set y axis limits to user supplied values
!
      ymn = ylb
      ymx = yub
    else
!
!  adjust y axis limits if equal
!
      if (ymn  >=  ymx) call adjlmt(ymn, ymx)
    end if

    if (xlb<xub) then
!
!  set x axis limits to user supplied values
!
      xmn = xlb
      xmx = xub
    else
!
!  adjust x axis limits if equal
!
      if (xmn  >=  xmx) call adjlmt(xmn, xmx)

    end if

  end if

  return

 1010 format (/ ' no non-missing plot coordinates were found.')
 1020 format (/ &
     ' no non-missing values were found within the user supplied limits.')
 1030 format (/ 'the plot has been suppressed.')
end
subroutine ppmc ( ym, ymmiss, x, xmiss, n, ilog, isize, nout, ylb, &
  yub, xlb, xub )

!*****************************************************************************80
!
!! PPMC: simple page plot for data with missing observations (long call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,isize,n,nout
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(1)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'p',       'p',       'm',       'c',       ' ',       ' '/

  m = 1
  iym = n
  multi = .false.
  ischck = 0
  miss = .true.
  lisym = 1

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ppmc (y, ymiss, x, xmiss, n, ilog,'/ &
     '      +           isize, nout, ylb, yub, xlb, xub)')
end
subroutine ppm ( ym, ymmiss, x, xmiss, n )

!*****************************************************************************80
!
!! PPM: simple page plot for data with missing observations (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xmiss
  integer &
     n
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(1)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xub,ylb,yub
  integer &
     ilog,ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'p',       'p',       'm',       ' ',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ppm (y, ymiss, x, xmiss, n)')
end
subroutine ppml ( ym, ymmiss, x, xmiss, n, ilog )

!*****************************************************************************80
!
!! PPML plots data with missing observations (log option).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xmiss
  integer &
     ilog,n
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(1)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xub,ylb,yub
  integer &
     ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  'p',       'p',       'm',       'l',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return
 1000 format (/' the correct form of the call statement is'// &
     '       call ppml (y, ymiss, x, xmiss, n, ilog)')
end
subroutine ppmn ( ym, ymmiss, x, xmiss, n, m, iym, ischck, isym, &
    lisym, isize, nout, ymn, ymx, xmn, xmx, miss, ilog )

!*****************************************************************************80
!
!! PPMN is the main routine for page plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!     input arguments - (in order of usage)
!
!        x  the n vector of observations for the x
!           coordinates
!        y  the n by m matrix of observations for the y (vertical)
!           coordinates
!           the ith column is plotted using the following symbol
!               1 = a    2 = b    3 = c    4 = d
!               5 = e    6 = f    7 = g    8 = h
!               9 = i   10 = j   11 = k   12 = l
!              13 = m   14 = n   15 = o   16 = p
!              17 = q   18 = r   19 = s   20 = t
!              21 = u   22 = v   23 = w   24 = y
!              25 (and above) = z
!           the numbers 1 to 9 indicate multiple points on a given
!           plot location, where the number indicates how many points
!           are represented
!           note that  x  is not used as a plotting symbol except to
!           indicate that more than 9 points fell on the same plot
!           location
!        n  the integer number of observations to be plotted (in each
!           column)
!        m  the number of columns in the y array to be plotted versus x
!           for the case of a vector y, m must be equal to 1
!    iym  the actual integer value of the row dimension of the y array
!           when y is a vector (m == 1) iym should be set equal to n
!   ischck  the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     isym  the n vector of integers determining the plotting symbols to
!           used for the s series of plots, where
!               1 = +    2 = .    3 = *    4 = -
!               5 = a    6 = b    7 = c    8 = d
!               9 = e   10 = f   11 = g   12 = h
!              13 = i   14 = j   15 = k   16 = l
!              17 = m   18 = n   19 = o   20 = p
!              21 = q   22 = r   23 = s   24 = t
!              25 = u   26 = v   27 = w   28 = y
!              29 (and above) = z
!           the numbers 1 to 9 indicate multiple points on a given
!           plot location, where the number indicates how many points
!           are represented
!           note that  x  is not used as a plotting symbol except to
!           indicate that more than 9 points fell on the same plot
!           location
!    isize  the integer code for the plot size, where
!           0 indicates a plot 100 col by 50 rows
!           1 indicates a plot 50 col by  50 rows
!     nout  the integer value indicating how many of the points which
!           fell outside of the graph limits are to be listed
!           if xlb == xub and ylb == yub, nout should be set to zero
!     xlb  the minimum value of x to be plotted(ie, the lower bound for
!           the x axis), where if xlb=xub the routine will determine
!           this value from the minimum value of the x vector
!     xub  the maximum value of x to be plotted(ie, the upper bound for
!           the x axis), where if xlb=xub the routine will determine
!           this value from the maximum value of the x vector
!     ylb  the minimum value of y to be plotted(ie, the lower bound for
!           the y axis), where if ylb=yub the routine will determine
!           this value from the minimum value of the y vector
!     yub  the maximum value of y to be plotted(ie, the upper bound for
!           the y axis), where if ylb=yub the routine will determine
!           this value from the maximum value of the y vector
!     ilog  the integer indicator variable used to determine whether
!           the y axis scale is to be log or not
!           if ilog == 0, the scale is not log
!           if ilog /= 0, the scale is log
!
!
!     additional variables used - (in alphabetical order)
!
!    aline  the vector of the current plot line
!   alphai  the plot axis symbol i
!   axisch  the y a axis symbol to be used for the current line,
!           either i or -
!   alphax  the plotting symbol x designating more than 9 points fell on
!           a single plotting location
!    blank  the plotting symbol blank
!     delx  the range of the x axis
!     dely  the range of the y axis
!   hyphen  the plot axis symbol -
!       ic  the count of the number of values falling outside of the
!           graph bounds
!     icol  the column location for the plot line
!     iout  the minimum of nout or 50, indicating how many of the
!           points which fell outside of the graph limits will actually
!           be listed
!   ipcode  the integer code, used in error checking, which determines
!           which plot routine has been called
!      ipr  the unit number of the printer
!    itest  the indicator variable for whether the x axis labels are
!           printed in e or f format
!      kss  an integer vector used in determining the plot symbol
!           needed
!       nn  the number of y labels to be listed on the left axis,
!           (dependent on the graph size)
!   numcol  the integer value of the number of columns in the graph
!   numlab  the integer number of x labels to be listed at the bottom
!           of the graph (dependent on graph size)
!   numrow  the integer number of rows in the graph
!      sym  the vector of plot symbol assignments (see is above)
!     sym1  the vector of integer values used to indicate multiple
!           points on the same plot location
!     temp  the array of values to be printed which fall outside the
!           graph limits
!   xlabel  the vector of x axis labels
!       xmn  the minimum x value to be plotted, computed from data or
!           assigned by xlb
!   xwidth  the value of an individual x axis graph interval
!       xmx  the maximum x value to be plotted, computed from data or
!           assigned by xub
!   ylabel  the value of the y axis label to be printed
!   ylower  the lower bound for y values to be plotted on the current
!           line
!       ymn  the minimum y value to be plotted, computed from data or
!           assigned by ylb
!   yupper  the upper bound for y values to be plotted on the current
!           line
!   ywidth  the value of an individual y axis graph interval
!       ymx  the maximum y value to be plotted, computed from data or
!           assigned by yub
!
!
  implicit none

  real xmiss
  real xmn
  real xmx
  real ymn
  real ymx

  integer &
     ilog,ischck,isize,iym,lisym,m,n,nout
  logical &
     miss
!
!  array arguments
  real &
     x(n),ym(iym,m),ymmiss(m)
  integer &
     isym(lisym)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     delx,dely,tn,tx,xdmn,xdmx,xwidth,xx,ydmn,ydmx,yl,ylower, &
     yupper,ywidth,yy
  integer &
     i,ic,icol,ik,ilogx,ilogy,iout,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
!
!  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
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer aline(105)
!     character*1 alphai, alphax
!     character*1 axisch
!     character*1 blank
!     character*1 cline(105)
!     real delx, dely
!     character fmt*4
!        the format for the x-axis labels
!     character*1 hyphen
!     integer i, ic, icol, ierr, ik
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ilogx
!        the values of p as specified by ilog.
!     integer ilogxy(2)
!        the values of p and q as specified by ilog.
!     integer ilogy
!        the values of q as specified by ilog.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isizxy(2)
!     integer ispace(20)
!        the spacing for the x-axis labels
!     integer isym(lisym)
!     integer it
!     character*1 itemp(50)
!     integer itest
!     integer iym
!     integer j, jcol
!     integer k
!     integer kss(101)
!     integer l
!     integer lisym
!     integer m
!     logical miss
!     integer n
!     integer nlablx, nlably, nlu
!     integer nn, nout, numcol, numcp2, numrow
!     character*1 sym(30), sym1(9)
!     real temp(50, 2)
!     real tn, tx
!     real x(n)
!     real xdmn, xdmx
!        the x-axis data limits actually used.
!     real xlabel(20)
!        the x-axis lables.
!     character xlfmt*205, xlfmt2*205
!        the formats used to print the x-axis
!     real xmiss, xmn, xmx, xwidth, xx
!     real ydmn, ydmx
!        the y-axis data limits actually used.
!     real yl
!     real ylabel(20)
!        the y-axis lables.
!     real ylower
!     real ym(iym, m)
!     real ymmiss(m)
!     real ymn, ymx, yupper, ywidth, yy
!
  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'/
!
!  define the number of rows and columns within the plot
!
  call prtcnt(max(0,isize),2,isizxy)

  if (isizxy(1) == 0) then
    numcol=101
  else
    numcol = 51
  end if

  if (isizxy(2) == 0) then
    numrow = 51
  else
    numrow = 26
  end if

  numcp2 = numcol + 2
  nn=(numrow-1)/5
!
!  Adjust for log plots if necessary and find axis labels.
!
  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)
!
!  Test for format for y axis labels.
!
  itest=0
  tx=ymx
  tn=ymn

  if ( ilogy /= 0) then
    tx = 10.0e0**tx
    tn = 10.0e0**tn
  end if

! 190

  if ((tn  >=  1.0e6 .or. tn <= (-1.0e5)) .or. &
     (abs(tn) > 0.0e0.and.abs(tn)<0.001e0)) itest=1

  if ((tx  >=  1.0e6 .or. tx <= (-1.0e5)) .or. &
     (abs(tx) > 0.0e0.and.abs(tx)<0.001e0)) itest=1
!
!  blank out the plot print line cline
!
  cline(1:105)=blank
!
!  write out the top horizontal axis of the plot
!
  cline(1:numcol)=hyphen
  cline(1)=alphai

  if (ilogx == 0) then
    do icol=11,numcol,10
       cline(icol)=alphai
    end do
  else
    do ik = nlablx, 1, -1
      icol = int ( ((log10(xlabel(ik))-xmn)/xwidth)+1.5e0 )
      cline(icol) = alphai
    end do
  end if

  cline(numcol+1)=hyphen
  cline(numcol+2)=blank
  write ( *, 1004) hyphen,(cline(i),i=1,numcol),hyphen
  cline(1:105)=blank
!
!  determine and write out the plot positions one line at a time.
!
  l=-1
  ik=1

  do irow=1,numrow

    l=l+1
    if (l > nn) l=1
    aline(1:numcol)=0
    kss(1:numcol)=0
    yupper=ymx+(1.5e0-real ( irow ) )*ywidth
    ylower=ymx+(0.5e0-real ( irow ) )*ywidth

    do i = 1, n

      if (miss .and. mvchk(x(i), xmiss)) then
        cycle
      end if

      if (ilogx == 0) then
        xx=x(i)
      else
        xx=log10(x(i))
      end if

      do j=1,m

        if (miss .and. mvchk(ym(i,j), ymmiss(j))) then
          cycle
        end if

           if (ilogy == 0) then
             yy=ym(i,j)
           else
             yy=log10(ym(i,j))
           end if
           if (((ylower <= yy).and.(yy<yupper)) .and. &
               ((yy >= ydmn).and.(yy <= ydmx))) then
              if ((xx >= xdmn) .and. (xx <= xdmx)) then
                 icol=int ( ((xx-xmn)/xwidth)+1.5e0 )
                 aline(icol) = aline(icol) + 1
!
!  simple plotting (plt)
!
                 kss(icol)=1
!
!  symbol plots (splt)
!
                 if (ischck == 1) kss(icol) = isym(i)
!
!  multiple plots (mplt)
!
                 if (ischck == 2) kss(icol) = j + 4
                 if (kss(icol) > 30) kss(icol)=30
                 if (kss(icol)<1) kss(icol)=1
              end if
           end if

        end do

     end do

     do icol=1,numcol
        if (aline(icol) == 0) then
          cline(icol)=blank
        else
          if (aline(icol) == 1) then
            k=kss(icol)
            cline(icol)=sym(k)
          else
            if (aline(icol) <= 9) then
              cline(icol)=sym1(aline(icol))
            else
              cline(icol)=alphax
            end if
          end if
        end if
     end do

     cline(numcol+2)=hyphen
     axisch=hyphen
     if (ilogy == 0) then
       yl = ylabel(ik)
     else
       yl = log10(ylabel(ik))
     end if
     if ((ylower > yl) .or. (yl >= yupper)) then
!
!  print line without label
!
       cline(numcp2)=alphai
       write ( *, 1008) alphai, (cline(icol), icol=1,numcp2)
     else
!
!  print line with label
!
       if (itest == 0) then
         write ( *,1006) ylabel(ik),axisch, &
           (cline(icol),icol=1,numcp2)
       else
         write ( *,1007) ylabel(ik),axisch, &
           (cline(icol),icol=1,numcp2)
       end if
       ik=ik+1
     end if

  end do
!
!  write out the bottom horizontal axis and the x axis labels.
!
  cline(1:numcol)=hyphen
  cline(1)=alphai

  if (ilogx == 0) then

    nlu = nlablx+1
    do icol=numcol,1,-10
       cline(icol)=alphai
       nlu = nlu - 1
       ispace(nlu) = 1
    end do

  else

    jcol = 1
    cline(jcol) = alphai
    nlu = nlablx
    do ik = nlablx, 1, -1
      icol = int ( ((log10(xlabel(ik))-xmn)/xwidth)+1.5 )
      cline(icol) = alphai
      if (icol-jcol >= 10) then
        ispace(nlu) = icol-jcol-9
        nlu = nlu - 1
        xlabel(nlu) = xlabel(ik)
        jcol = icol
      end if
    end do

  end if
  cline(numcol+1)=hyphen
  cline(numcol+2)=blank

  write ( *, 1004) hyphen, (cline(icol), icol = 1, numcp2)
!
!  check x-axis labels for format
!
  fmt = 'f9.4'
  do i=1,nlablx
    if (((abs(xlabel(i)) > 0.0e0) .and. (abs(xlabel(i))<0.01e0)) &
        .or. &
        ((xlabel(i) >= 1.0e4) .or. (xlabel(i) <= (-1.0e3)))) then
      fmt = 'e9.4'
      exit
     end if
  end do

  write(xlfmt2,1000) nlablx-nlu
  write(xlfmt,xlfmt2) (fmt, ispace(i), i=nlablx,nlu+1,-1), fmt
  write ( *, xlfmt) (xlabel(i),i=nlablx,nlu,-1)
!
!  determine values to be listed if outside of axis limits.
!
  ic = 0
  iout = min(nout,50)
  if (iout >= 0) then

    do i = 1, n

      if (miss .and. mvchk(x(i), xmiss)) then
         cycle
      end if

      if (ilogx == 0) then
        xx = x(i)
      else
        xx = log10(x(i))
      end if

       do j = 1, m

          if (miss .and. mvchk(ym(i,j), ymmiss(j))) then
            cycle
          end if

          if (ilogy == 0) then
            yy = ym(i,j)
          else
            yy = log10(ym(i,j))
          end if

          if (((ydmn <= yy) .and. (yy <= ydmx)) .and. &
              ((xdmn <= xx) .and. (xx <= xdmx))) then
            cycle
          end if

          ic=ic+1

          if ( ic <= iout ) then
            temp(ic,1)=x(i)
            temp(ic,2)=ym(i,j)
            it=1
            if (ischck == 1) it=isym(i)
            if (ischck == 2) it=j+4
            it = max ( it, 1 )
            it = min ( it, 30 )
            itemp(ic) = sym(it)
           end if

        end do

    end do

  end if
!
!  check for points outside of graph limits and list if requested
!  the total number of points to be plotted is n*m
!
  if (ic == 0) return
  if (iout < 0) return
  write ( *, 1010) ic
  if (iout <= 0) return
  write ( *, 1016)
  if (ic <= iout) go to 360
  ic=iout
  write ( *, 1011) iout
  go to 370
  360 write ( *, 1012)
  370 write ( *, 1013) (temp(i,1), temp(i,2), itemp(i), i = 1, ic)
  return

 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,'**note',i4, &
  'values fell outside the specified limit s**')
 1011 format ('1', 15x, 'the first ', i3, &
     ' values outside the plot limits are'/ 22x, &
   ' x               y            sym')
 1012 format ('1', 15x, 'the values outside the plot limits are'/ 22x, &
   ' x               y            sym')
 1013 format (15x,2e15.8,9x,a1)
 1016 format (16x, 'see next page for list')
end
subroutine prtcnt ( nprt, ndigit, iptout )

!*****************************************************************************80
!
!! PRTCNT sets up the print control parameters.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer iptout(ndigit)
!        the variable used to control printed output for each section.
!     integer ndigit
!        the number of digits in the print control value.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!
  implicit none

  integer &
     ndigit,nprt
!
!  array arguments
  integer &
     iptout(ndigit)

  integer &
     i,ifac1,ifac2

  if ( nprt <= -1 ) then

    iptout(1:ndigit) = 1
    iptout (ndigit) = 2

  else

    ifac1 = 10 ** (ndigit)
    do i = 1, ndigit
      ifac2 = ifac1/10
      iptout(i) = mod(nprt, ifac1) / ifac2
      ifac1 = ifac2
    end do

  end if

  return
end
subroutine qapply ( nn, n, p, j, r, ierr )

!*****************************************************************************80
!
!! QAPPLY applies orthogonal transformation to the residual R.
!
!  Discussion:
!
!    This subroutine applies to R the orthogonal transformations
!    stored in J by QRFACT.
!
!    The vectors U which determine the Householder transformations
!    are normalized so that their 2-norm squared is 2.  The use of
!    these transformations here is in the spirit of Businger and Golub.
!
!  Modified:
!
!    06 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    Peter Businger, Gene Golub,
!    Linear Least Squares Solutions by Householder Transformations,
!    Numerische Mathematik,
!    Volume 7, pages 269-276, 1965.
!
!  Parameters:
!
!    Input, integer NN, the row dimension of the matrix J as declared in
!    the calling program dimension statement
!
!    Input, integer N, the number of rows of J and the size of the R.
!
!    Input, integer P, the number of columns of J and the size of SIGMA.
!
!    Input, real J(NN,P), an N by P matrix.  It contains on its diagonal
!    and below its diagonal the column vectors U which determine the
!    Householder transformations (identity - U*U').
!
!    Input/output, real R(N).  On input, the right hand side vector to
!    which the orthogonal transformations will be applied.  On output,
!    R has been transformed.
!
!    Input, integer IERR, if non-zero, indicates that not all the
!    transformations were successfully determined and only the first
!    abs(IERR) - 1 transformations will be used.
!
  implicit none

  integer n
  integer nn
  integer p

  real dotprd
  integer ierr
  real j(nn,p)
  integer k
  integer l
  integer nl1
  real r(n)
  real t

  if ( ierr /= 0 ) then
    k = abs(ierr) - 1
  else
    k = p
  end if

  do l = 1, k

    nl1 = n - l + 1
    t = -dotprd ( nl1, j(l,l), r(l) )
    r(l:n) = r(l:n) + t * j(l:n,l)

  end do

  return
end
subroutine qrfact ( nm, m, n, qr, alpha, ipivot, ierr, nopivk, sum )

!*****************************************************************************80
!
!! QRFACT computes the QR decomposition of a matrix.
!
!  Discussion:
!
!    This subroutine does a QR decomposition on the M x N matrix QR,
!    with an optionally modified column pivoting, and returns the
!    upper triangular R matrix, as well as the orthogonal vectors
!    used in the transformations.
!
!    This may be used when solving linear least-squares problems.
!    See subroutine QR1 of ROSEPACK.  It is called for this purpose
!    in the NL2SOL package.
!
!    This version of QRFACT tries to eliminate the occurrence of
!    underflows during the accumulation of inner products.  RKTOL1
!    is chosen below so as to insure that discarded terms have no
!    effect on the computed two-norms.
!
!    This routine was adapted from Businger and Golub's ALGOL
!    routine "SOLVE".
!
!    This routine is equivalent to the subroutine QR1 of ROSEPACK
!    with RKTOL1 used in place of RKTOL below, with V2NORM used
!    to initialize (and sometimes update) the sum array, and
!    with calls on DOTPRD in place of some loops.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Reference:
!
!    Peter Businger, Gene Golub,
!    Linear Least Squares Solutions by Householder Transformations,
!    in Handbook for Automatic Computation,
!    Volume II, Linear Algebra,
!    edited by James Wilkinson and C Reinsch,
!    Springer Verlag, pages 111-118, 1971;
!    prepublished in Numerische Mathematik,
!    Volume 7, pages 269-276, 1965.
!
!  Parameters:
!
!    Input, integer NM, the row dimension of the two dimensional
!    array parameters as declared in the calling program dimension statement.
!
!    Input, integer M, the number of rows in the matrix.
!
!    Input, integer N, the number of columns in the matrix.
!
!    Input/output, real QR(NM,N), on input, the M by N rectangular matrix
!    to be decomposed.  On output, contains the non-diagonal elements of
!    the R matrix in the strict upper triangle.  The vectors U, which
!    define the Householder transformations (Identity - U*U'), are in the
!    columns of the lower triangle.  These vectors U are scaled so that
!    the square of their 2-norm is 2.0.
!
!    Output, real ALPHA(N), the diagonal elements of R.
!
!    Output, integer IPIVOT(N), reflects the column pivoting performed
!    on the input matrix to accomplish the decomposition.  The J-th
!    element of IPIVOT gives the column of the original matrix which was
!    pivoted into column J during the decomposition.
!
!    Output, integer IERR, error flag.
!    0, for normal return,
!    K, if no non-zero pivot could be found for the K-th transformation,
!    -K, for an error exit on the K-th transformation.
!    If an error exit was taken, the first (K - 1) transformations are correct.
!
!    Input, integer NOPIVK, controls pivoting.  Columns 1 through NOPIVK
!    will remain fixed in position.
!
!    Workspace, real SUM(N).
!
!  Local Parameters:
!
!    Local, real UFETA, the smallest positive floating point number
!    such that UFETA and -UFETA can both be represented.
!
!    Local, real RKTOL, the square root of the relative precision
!    of floating point arithmetic (MACHEP).
!
  implicit none

  integer n
  integer nm

  real alpha(n)
  real alphak
  real beta
  real dotprd
  integer i
  integer ierr
  integer ipivot(n)
  integer j
  integer jbar
  integer k
  integer m
  integer minum
  integer mk1
  integer nopivk
  real qr(nm,n)
  real qrkk
  real qrkmax
  real, save :: rktol = 0.0E+00
  real rktol1
  real sigma
  real sum(n)
  real sumj
  real temp
  real, save :: ufeta = 0.0E+00
  real v2norm

  if ( ufeta <= 0.0E+00 ) then
    ufeta = tiny ( ufeta )
    rktol = sqrt ( 0.999E+00 * epsilon ( rktol ) )
  end if

  ierr = 0
  rktol1 = 0.01E+00 * rktol

  do j = 1, n
    sum(j) = v2norm ( m, qr(1,j) )
    ipivot(j) = j
  end do

  minum = min ( m, n )

  do k = 1, minum

    mk1 = m - k + 1
!
!  K-th Householder transformation.
!
    sigma = 0.0E+00
    jbar = 0
!
!  Find largest column sum.
!
    if ( nopivk < k ) then

      do j = k, n
        if ( sigma < sum(j) ) then
          sigma = sum(j)
          jbar = j
        end if
      end do

      if ( jbar == 0 ) then
        ierr = k
        do i = k, n
          alpha(i) = 0.0E+00
          if ( k < i ) then
            qr(k:i-1,i) = 0.0E+00
          end if
        end do
        return
      end if
!
!  Column interchange.
!
      i = ipivot(k)
      ipivot(k) = ipivot(jbar)
      ipivot(jbar) = i

      sum(jbar) = sum(k)
      sum(k) = sigma

      do i = 1, m
        sigma = qr(i,k)
        qr(i,k) = qr(i,jbar)
        qr(i,jbar) = sigma
      end do

    end if
!
!  Second inner product.
!
    qrkmax = maxval ( abs ( qr(k:m,k) ) )

    if ( qrkmax < ufeta ) then
      ierr = -k
      do i = k, n
        alpha(i) = 0.0E+00
        if ( k < i ) then
          qr(k:i-1,i) = 0.0E+00
        end if
      end do
      return
    end if

    alphak = v2norm ( mk1, qr(k,k) ) / qrkmax
    sigma = alphak**2
!
!  End second inner product.
!
    qrkk = qr(k,k)
    if ( 0.0E+00 <= qrkk ) then
      alphak = -alphak
    end if

    alpha(k) = alphak * qrkmax
    beta = qrkmax * sqrt ( sigma - ( qrkk * alphak / qrkmax ) )
    qr(k,k) = qrkk - alpha(k)
    qr(k:m,k) =  qr(k:m,k) / beta

    do j = k + 1, n

      temp = -dotprd ( mk1, qr(k,k), qr(k,j) )

      qr(k:m,j) = qr(k:m,j) + temp * qr(k:m,k)

      if ( k + 1 <= m ) then
        sumj = sum(j)
        if ( ufeta <= sumj ) then
          temp = abs ( qr(k,j) / sumj )
          if ( rktol1 <= temp ) then
            if ( 0.99E+00 <= temp ) then
              sum(j) = v2norm ( m-k, qr(k+1,j) )
            else
              sum(j) = sumj * sqrt ( 1.0E+00 - temp**2 )
            end if

          end if
        end if
      end if

    end do

  end do

  return
end
function r1mach ( i )

!*****************************************************************************80
!
!! R1MACH returns single precision real machine constants.
!
!  Discussion:
!
!    Assume that single precision real numbers are stored with a mantissa 
!    of T digits in base B, with an exponent whose value must lie 
!    between EMIN and EMAX.  Then for values of I between 1 and 5, 
!    R1MACH will return the following values:
!
!      R1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!      R1MACH(2) = B**EMAX*(1-B**(-T)), the largest magnitude.
!      R1MACH(3) = B**(-T), the smallest relative spacing.
!      R1MACH(4) = B**(1-T), the largest relative spacing.
!      R1MACH(5) = log10(B)
!
!  Modified:
!
!    24 April 2007
!
!  Author:
!
!    Phyllis Fox, Andrew Hall, Norman Schryer
!
!  Reference:
!
!    Phyllis Fox, Andrew Hall, Norman Schryer,
!    Algorithm 528,
!    Framework for a Portable Library,
!    ACM Transactions on Mathematical Software,
!    Volume 4, Number 2, June 1978, page 176-188.
!
!  Parameters:
!
!    Input, integer I, chooses the parameter to be returned.
!    1 <= I <= 5.
!
!    Output, real R1MACH, the value of the chosen parameter.
!
  implicit none

  integer i
  real r1mach

  if ( i < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R1MACH - Fatal error!'
    write ( *, '(a)' ) '  The input argument I is out of bounds.'
    write ( *, '(a)' ) '  Legal values satisfy 1 <= I <= 5.'
    write ( *, '(a,i12)' ) '  I = ', i
    r1mach = 0.0E+00
    stop
  else if ( i == 1 ) then
    r1mach = 1.1754944E-38
  else if ( i == 2 ) then
    r1mach = 3.4028235E+38
  else if ( i == 3 ) then
    r1mach = 5.9604645E-08
  else if ( i == 4 ) then
    r1mach = 1.1920929E-07
  else if ( i == 5 ) then
    r1mach = 0.3010300E+00
  else if ( 5 < i ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R1MACH - Fatal error!'
    write ( *, '(a)' ) '  The input argument I is out of bounds.'
    write ( *, '(a)' ) '  Legal values satisfy 1 <= I <= 5.'
    write ( *, '(a,i12)' ) '  I = ', i
    r1mach = 0.0E+00
    stop
  end if
 
  return
end
function r9gmit ( a, x, algap1, sgngam, alx )

!*****************************************************************************80
!
!! R9GMIT computes Tricomi's incomplete gamma function for small X.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real a
  real ae
  real aeps
  real alg2
  real algap1
  real alx
  integer k
  integer m
  integer ma
  real r9gmit
  real sgngam
  real x

  real algs,bot,eps,fk,s,sgng2,t,te
!
!  external functions
  real alngam
  external alngam

  data eps, bot / 2*0.0 /

  if (eps == 0.0) eps = 0.25 * epsilon ( eps )
  if (bot == 0.0) bot = log( tiny ( bot ) )

  if ( x <= 0.0 ) then
    call xerror ('r9gmit  x should be gt 0', 1, 2)
  end if

  ma = int ( a + 0.5 )
  if (a<0.0) ma = int ( a - 0.5 )
  aeps = a - real ( ma )

  if ( a < -0.5 ) then
    ae = aeps
  else
    ae = a
  end if

  t = 1.0
  te = ae
  s = t

  do k = 1, 200
    fk = real ( k )
    te = -x*te/fk
    t = te/(ae+fk)
    s = s + t
    if (abs(t)<eps*abs(s)) go to 30
  end do

  call xerror (  &
    'r9gmit  no convergence in 200 terms of taylor-s series', 2, 2)

 30   continue

  if (a >= (-0.5)) then

     algs = -algap1 + log(s)

  else

     algs = -alngam(1.0+aeps) + log(s)
     s = 1.0
     m = -ma - 1
     t = 1.0
     do k=1,m
        t = x*t/(aeps-real ( m+1-k ))
        s = s + t
        if (abs(t)<eps*abs(s)) then
          exit
        end if
     end do

     r9gmit = 0.0
     algs = -real( ma )*log(x) + algs

     if (s /= 0.0 .and. aeps /= 0.0) then
        sgng2 = sgngam*sign(1.0,s)
        alg2 = -x - algap1 + log(abs(s))
        if (alg2 > bot) r9gmit = sgng2*exp(alg2)
        if (algs > bot) r9gmit = r9gmit + exp(algs)
        return
     end if

  end if

  r9gmit = exp ( algs )

  return
end
function r9lgic ( a, x, alx )

!*****************************************************************************80
!
!! R9LGIC compute the log complementary incomplete gamma function.
!
!  Discussion:
!
!    This routine is suitable for large x and for a <= x.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real a
  real alx
  real r9lgic
  real x
!
!
  real eps,fk,p,r,s,t,xma,xpa
  integer k

  data eps / 0.0 /

  if (eps == 0.0) eps = 0.25 * epsilon ( eps )

  xpa = x + 1.0 - a
  xma = x - 1.0 - a

  r = 0.0
  p = 1.0
  s = p
  do k = 1, 200
    fk = real ( 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)<eps*s) go to 20
  end do

  call xerror (  &
    'r9lgic  no convergence in 200 terms of continued fraction', 1, 2)

 20   r9lgic = a*alx - x + log(s/xpa)

  return
end
function r9lgit ( a, x, algap1 )

!*****************************************************************************80
!
!! R9LGIT computes the log of Tricomi's incomplete Gamma function.
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
!
! compute the log of tricomi-s incomplete gamma function with perron-s
! continued fraction for large x and for a  >=  x.
!
!
  implicit none

  real a
  real a1x
  real algap1
  real ax
  real, save :: eps = 0.0E+00
  real fk
  real hstar
  integer k
  real p
  real r
  real r9lgit
  real s
  real, save :: sqeps = 0.0E+00
  real t
  real x

  if ( eps == 0.0 ) then
    eps = 0.25 * epsilon ( eps )
  end if

  if ( sqeps == 0.0 ) then
    sqeps = sqrt ( epsilon ( sqeps ) )
  end if

  if (x <= 0.0 .or. a<x) then
    call xerror (  'r9lgit  x should be gt 0.0 and le a', 2, 2)
  end if

  ax = a + x
  a1x = ax + 1.0
  r = 0.0
  p = 1.0
  s = p

  do k = 1, 200
    fk = real ( k )
    t = (a+fk)*x*(1.0+r)
    r = t/((ax+fk)*(a1x+fk)-t)
    p = r*p
    s = s + p
    if (abs(p)<eps*s) go to 30
  end do

  call xerror (  &
    'r9lgit  no convergence in 200 terms of continued fraction', 3, 2)

 30   hstar = 1.0 - x*s/a1x
  if (hstar<sqeps) call xerror ( &
    'r9lgit  result less than half precision', 1, 1)

  r9lgit = -x - algap1 - log(hstar)

  return
end
function r9lgmc ( x )

!*****************************************************************************80
!
!! R9LGMC computes the log Gamma correction factor.
!
!  Discussion:
!
!    compute the log gamma correction factor for x  >=  10.0 so that
!    log (gamma(x)) = log(sqrt(2*pi)) + (x-.5)*log(x) - x + r9lgmc(x)
!
!  Modified:
!
!    24 April 2006
!
!  Author:
!
!    Wayne Fullerton,
!    Los Alamos National Laboratory,
!    Los Alamos, New Mexico.
!
  implicit none

  real r9lgmc
  real x
!
!
  real xbig,xmax
  integer nalgm
!
!  local arrays
  real algmcs(6)
!
!  external functions
  real csevl
  integer inits
  external csevl,inits
!
! series for algm       on the interval  0.          to  1.00000d-02
!                                        with weighted error   3.40e-16
!                                         log weighted error  15.47
!                               significant figures required  14.39
!                                    decimal places required  15.86
!
  data algmcs( 1) /    .166638948045186e0 /
  data algmcs( 2) /   -.0000138494817606e0 /
  data algmcs( 3) /    .0000000098108256e0 /
  data algmcs( 4) /   -.0000000000180912e0 /
  data algmcs( 5) /    .0000000000000622e0 /
  data algmcs( 6) /   -.0000000000000003e0 /

  data nalgm, xbig, xmax / 0, 2*0.0 /

  if ( nalgm == 0 ) then
    nalgm = inits ( algmcs, 6, 0.5 * epsilon ( x ) )
    xbig = 1.0 / sqrt ( epsilon ( xbig ) )
    xmax = exp (min(log(huge ( xmax ) /12.0), -log(12.0* tiny ( xmax ) )) )
  end if

  if (x<10.0) call xerror ('r9lgmc  x must be ge 10', 1, 2)

  if (x >= xmax) then
    r9lgmc = 0.0
    call xerror ('r9lgmc  x so big r9lgmc underflows', 2, 1)
    return
  end if

  r9lgmc = 1.0/(12.0*x)
  if (x<xbig) r9lgmc = csevl (2.0*(10./x)**2-1., algmcs, nalgm)/x

  return
end
function randn ( jd )

!*****************************************************************************80
!
!! RANDN returns normal random numbers.
!
!  Discussion:
!
!    generates quasi normal random numbers, with mean zero and
!    unit standard deviation, and can be used with any computer
!    with integers at least as large as 32767.
!
!    randn generates quasi normal random numbers with zero mean and
!    unit standard deviation.
!    it can be used with any computer with integers at least as
!    large as 32767.
!
!    use:
!
!    first time....
!      z = randn(jd)
!    here jd is any  n o n - z e r o  integer.
!    this causes initialization of the program
!    and the first random number to be returned as z.
!
!    subsequent times...
!      z = randn(0)
!    causes the next random number to be returned as z.
!
!    users who wish to transport this program to other
!    computers should read the following ....
!
!    machine dependencies:
!
!    mdig = a lower bound on the number of binary digits available
!    for representing integers, including the sign bit.
!    this must be at least 16, but can be increased in
!    line with remark a below.
!
!    this program can be used in two ways:
!    (1) to obtain repeatable results on different computers,
!        set 'mdig' to the smallest of its values on each, or,
!    (2) to allow the longest sequence of random numbers to be
!        generated without cycling (repeating) set 'mdig' to the
!        largest possible value.
!
!    the sequence of numbers generated depends on the initial
!    input 'jd' as well as the value of 'mdig'.
!    if mdig=16 one should find that
!    the first evaluation
!    z=randn(87) gives  z=-.40079207...
!    the second evaluation
!    z=randn(0) gives   z=-1.8728870...
!    the third evaluation
!    z=randn(0) gives   z=1.8216004...
!    the fourth evaluation
!    z=randn(0) gives   z=.69410355...
!    the thousandth evaluation
!    z=randn(0) gives   z=.96782424...
!
!  Author:
!
!    David Kahaner,
!    applied and computational mathematics divistion, nist
!
!    George Marsaglia
!    computer science dept., wash state univ
!
!    Janet Donaldson
!    Applied and computational mathematics divistion, nist
!
!  Reference:
!
!    Marsaglia, Tsang,
!    A fast, easily implemented method for sampling from decreasing or
!    symmetric unimodal density functions,
!    SIAM Journal of Scientific and Statistical Computing, 1983.
!
  implicit none

  integer jd
  real randn
!
  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
!
!  local arrays
  real &
     v(65),w(65)
  integer &
     m(17)
!
!  external functions
  real &
     randu
  integer &
     i1mach
  external randu,i1mach
!
!  save statement
  save i1,j1,m,m1,m2,rmax
!
  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/
!
! fast part...
!
  if (jd /= 0) then
!
!  fill
!
      mdig = i1mach(8) + 1
!
!  modification so same numbers will be generated on all machines
!  with i1mach(8) at least 31
!
      mdig = min(mdig,32)
!
!  be sure that mdig at least 16...
!
      if (mdig<16) call xerror('randn--mdig less than 16', 1, 2 )

      m1 = 2** (mdig-2) + (2** (mdig-2)-1)
      m2 = 2** (mdig/2)
      jseed = min(abs(jd),m1)
      if (mod(jseed,2) == 0) jseed = jseed - 1
      k0 = mod(9069,m2)
      k1 = 9069/m2
      j0 = mod(jseed,m2)
      j1 = jseed/m2
      do 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
      end do
      j1 = 17
      i1 = 5
      rmax = one/real(m1)
!
!  seed uniform (0,1] generator.  (just a dummy call)
!
      randn = randu(jd)
      w(1:65) = rmax*v(1:65)
  end if

  i = m(i1) - m(j1)
  if (i<0) i = i + m1
  m(j1) = i
  i1 = i1 - 1
  if (i1 == 0) i1 = 17
  j1 = j1 - 1
  if (j1 == 0) j1 = 17
  j = mod(i,64) + 1
  randn = real ( i ) * w(j+1)
  if (((i/m2)/2)*2 ==  (i/m2)) randn = -randn
!
!  slow part; aa is a*f(0)
!
  if (abs(randn) > v(j)) then

    x = (abs(randn)-v(j))/ (v(j+1)-v(j))
    y = randu(0)
    s = x + y

    if (s <= c2) then
      if (s <= c1) then
        return
      else if (y <= c-aa*exp(-p5 * (b-b*x)**2)) then
        if (exp(-p5*v(j+1)**2)+y*pc/v(j+1) > exp(-p5*randn**2)) then
!
! tail part; 3.855849 is .5*xn**2
!
          do
            s = xn - log(randu(0)) / xn
            if (3.855849e0+log(randu(0))-xn*s <= -p5*s**2) then
              exit
            end if
          end do

          randn = sign ( s, randn )

        end if

        return

      end if

    end if

    randn = sign ( b-b*x, randn )

  end if

  return
end
function randu ( jd )

!*****************************************************************************80
!
!! RANDU returns uniform random numbers.
!
!  Discussion:
!
!       this routine generates quasi uniform random numbers on the
!       interval (0,1].  it can be used with any computer which allows
!       integers at least as large as 32767.
!
!
!   use
!       first time....
!                   z = randu(jd)
!                     here jd is any  n o n - z e r o  integer.
!                     this causes initialization of the program
!                     and the first random number to be returned as z.
!       subsequent times...
!                   z = randu(0)
!                     causes the next random number to be returned as z.
!
!
!   note: users who wish to transport this program from one computer
!         to another should read the following information:
!
!   machine dependencies...
!      mdig = a lower bound on the number of binary digits available
!              for representing integers, including the sign bit.
!              this value must be at least 16, but may be increased
!              in line with remark a below.
!
!   remarks...
!     a. this program can be used in two ways:
!        (1) to obtain repeatable results on different computers,
!            set 'mdig' to the smallest of its values on each, or,
!        (2) to allow the longest sequence of random numbers to be
!            generated without cycling (repeating) set 'mdig' to the
!            largest possible value.
!     b. the sequence of numbers generated depends on the initial
!          input 'jd' as well as the value of 'mdig'.
!          if mdig=16 one should find that
!            the first evaluation
!              z=randu(305) gives z=.027832881...
!            the second evaluation
!              z=randu(0) gives   z=.56102176...
!            the third evaluation
!              z=randu(0) gives   z=.41456343...
!            the thousandth evaluation
!              z=randu(0) gives   z=.19797357...
!
!  Author:
!
!    James Blue, David Kahaner, George Marsaglia.
!
!    Modified by Janet Donaldson.
!
!  Reference:
!
!    Marsaglia,
!    Comments on the Perfect Uniform Random Number Generator,
!    unpublished notes, wash s. u.
!
  implicit none

  integer jd
  real randu
!
!
  real &
     one,zero
  integer &
     i,j,j0,j1,jseed,k,k0,k1,m1,m2,mdig
!
!  local arrays
  integer &
     m(17)
!
!  external functions
  integer &
     i1mach
  external i1mach
!
!  save statement
  save i,j,m,m1,m2
!
!
  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/

  if (jd /= 0) then
!
!  fill
!
      mdig = i1mach(8) + 1
!
!  modification so same numbers will be generated on all machines
!  with i1mach(8) at least 31
!
      mdig = min(mdig,32)
!
!  be sure that mdig at least 16.
!
      if (mdig<16) call xerror('randu--mdig less than 16', 1, 2 )
      m1 = 2** (mdig-2) + (2** (mdig-2)-1)
      m2 = 2** (mdig/2)
      jseed = min(abs(jd),m1)
      if (mod(jseed,2) == 0) jseed = jseed - 1
      k0 = mod(9069,m2)
      k1 = 9069/m2
      j0 = mod(jseed,m2)
      j1 = jseed/m2
      do 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
      end do
      i = 5
      j = 17
  end if
!
!  begin main loop here
!
  k = m(i) - m(j)
  if (k<0) k = k + m1
  m(j) = k
  i = i - 1
  if (i == 0) i = 17
  j = j - 1
  if (j == 0) j = 17
  randu = real(k)/real(m1)
!
!  modification so random numbers in (0,1] rather than [0,1)
!
  if (randu == zero) randu = one

  return
end
subroutine ranko ( n, y, h, r, t )

!*****************************************************************************80
!
!! RANKO puts the rank of N X's in the vector R.
!
!  Discussion:
!
!    This routine puts rank of n x"s in vector r. vector h is used for storage.
!     x,h and r must be dimensioned n or greater.
!     stores correction for ties in t = sum(t-1)*t*(t+1).
!        n.b.  t is 12 times value computed by original omnitab routine.
!     t=0  means no ties.
!
!  Author:
!
!    David Hogben,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     t
  integer &
     n
!
!  array arguments
  real &
     r(n),y(n)
  integer &
     h(n)
!
!
  integer &
     i,ij,j,k,k2
!
!  external subroutines
  external srtir,srtri
!
!     variable definitions (alphabetically)
!
!     integer h(n)
!        the indices to the hierarchy of r
!     integer i
!        index variable
!     integer ij
!        index variable based on i-j
!     integer j
!        index variable
!     integer k
!        index variable
!     integer k2
!          index variable
!     integer n
!        number of observations
!     real r(n)
!        final vector containing rank
!     real t
!        12 times the omnitab correction for ties
!             t = sum(t-1)*t*(t+1)
!             t = 0 means no ties
!     real y(n)
!        vector to be ranked
!
!
!  move y to r and put i in h
!
  do i=1,n
     h(i) = i
  end do
  r(1:n) = y(1:n)
!
!  sort y in r, carry along i in h to obtain hierarchy in h.
!
  call srtir(h, n, r)
!
!  replace r(i) by i*.
!  let k be such that r(i)=r(i-j+1),j=1,k. then i* = i-(k-1)/2.
!
  k = 1
  t = 0

  do i=2,n

    if (r(i) == r(i-1)) then

      k = k + 1

    else

      do j=1,k
        ij = i - j
        r(ij) = real (i-1) - real (k-1)/2.0e0
      end do

      t = t + real ( (k-1)*k*(k+1) )
      k = 1

    end if

  end do

  t = t + real ( (k-1)*k*(k+1) )
  do i=1,k
     k2 = n + 1 - i
     r(k2) = real ( n ) - real ( k - 1 ) / 2.0e0
  end do
!
!  sort h carry along r to obtain ranks in r
!
  call srtri(r, n, h)

  return
end
subroutine realtr ( a, b, n, isn )

!*****************************************************************************80
!
!! REALTR computes the forward or inverse Fourier transform of real data.
!
!  Discussion:
!
!    if isn=1, this subroutine completes the Fourier transform
!    of 2*n data values, where the original data values are
!    stored alternately in arrays a and b, and are first
!    transformed by a complex Fourier transform of dimension n.
!    the cosine coefficients are in a(1),a(2),...a(n+1) and
!    the sine coefficients are in b(1),b(2),...b(n+1).
!    a typical calling sequence is
!      call fft(a,b,n,n,n,1)
!      call realtr(a,b,n,1)
!    the results should be multiplied by 0.5e0/n to give the
!    usual scaling of coefficients.
!    ifisn-1, the inverse transformation is done, the first step
!    in evaluating a real Fourier series.
!    a typical calling sequence is
!      call realtra(a,b,n,-1)
!      call fft(a,b,n,n,n,-1)
!    the results should be multiplied by 0.5e0 to give the usual
!    scaling, and the time domain results alternate in arrays a
!    and b, i.e. a(1),b(1),a(2),b(2),...a(n),b(n).
!    the data may alternatively be stored in a single complex
!    array a, then the magnitude of isn changed to two to
!    give the correct indexing increment and a(2) used to
!    pass the initial address for the sequence of imaginary
!    values, e.g.
!      call fft(a,a(2),n,n,n,2)
!      call realtr(a,a(2),n,2)
!    in this case, the cosine and sine coefficients alternate in a.
!
!  Author:
!
!    RC Singleton,
!    Stanford Research Institute, 
!    October 1968.
!
!
  implicit none

  integer &
     isn,n
!
!  array arguments
  real &
     a(1),b(1)
!
!
  real &
     aa,ab,ba,bb,cd,cn,im,re,sd,sn
  integer &
     inc,j,k,nh,nk

  inc = iabs(isn)
  nk = n*inc + 2
  nh = nk/2
  sd = 2.0e0*atan(1.0e0)/ real ( n )
  cd = 2.0e0*sin(sd)**2
  sd = sin(sd+sd)
  sn = 0.0e0

  if ( isn < 0 ) then
    cn = -1.0E+00
    sd = -sd
  else
    cn = 1.0e0
    a(nk-1) = a(1)
    b(nk-1) = b(1)
  end if

  do 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
  end do

  return
end
subroutine relcom ( n, v, w, reltol, abstol, nfail, ifail )

!*****************************************************************************80
!
!! RELCOM computes the difference between V(I) and W(I) relative to RELTOL.
!
!  Discussion:
!
!    this subroutine computes the number of times the
!    relative difference between v(i) and w(i), i = 1, 2, ..., n,
!    is greater than   reltol  .
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     abstol,reltol
  integer &
     n,nfail
!
!  array arguments
  real &
     v(n),w(n)
  integer &
     ifail(n)

  integer &
     i
!
!     variable definitions (alphabetically)
!
!     real abstol
!        the absolute tolerance used in the comparison.
!     integer ifail(n)
!        an indicator variable designating whether or not the comparison
!        failed or not, where 0 indicates not failure and 1 indicates
!        falure.
!     integer n
!        the number of observations.
!     integer nfail
!        the total number of failures.
!     real reltol
!        the relative tolerance used in the comparison.
!     real v(n), w(n)
!        the values being compared.
!
  nfail = 0

  do i = 1, n
     if ((abs(v(i)-w(i)) <= reltol*max(abs(v(i)),abs(w(i)))) .or. &
         (((v(i) == 0.0e0).or.(w(i) == 0.0e0)).and. &
          (abs(v(i)-w(i)) <= abstol))) then
        ifail(i) = 0
     else
        ifail(i) = 1
        nfail = nfail + 1
     end if
  end do

  return
end
function reldst ( p, d, x, x0 )

!*****************************************************************************80
!
!! RELDST computes the relative difference between two real values.
!
!  Modified:
!
!    03 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer P, the length of the vectors.
!
!    Input, real D(P), a scaling vector.
!
!    Input, real X(P), X0(P), two vectors whose relative difference
!    is desired.
!
!    Output, real RELDST, the relative difference between X and X0.
!
  implicit none

  integer p

  real d(p)
  real emax
  integer i
  real reldst
  real x(p)
  real x0(p)
  real xmax

  emax = 0.0E+00
  xmax = 0.0E+00
  do i = 1, p
    emax = max ( emax, abs ( d(i) * ( x(i) - x0(i) ) ) )
    xmax = max ( xmax, d(i) * ( abs ( x(i) ) + abs ( x0(i) ) ) )
  end do

  if ( 0.0E+00 < xmax ) then
    reldst = emax / xmax
  else
    reldst = 0.0E+00
  end if

  return
end
subroutine repck ( d, nrests, npar, n )

!*****************************************************************************80
!
!! REPCK reformats the data in D for the N by NPAR format used by NLCMP.
!
!  Discussion:
!
!    this routine modifies d to conform to n by npar format required
!    by nlcmp.  future revisions to nlcmp should be made to eliminate
!    the need for this routine.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,npar,nrests
!
!  array arguments
  real &
     d(nrests*npar)

  integer &
     i,i1,i2,j

  i1 = -n
  i2 = -n
  do j = 1, npar
    i1 = i1 + nrests
    i2 = i2 + n
    do i = 1, n
      d(i2+i) = d(i1+i)
    end do
  end do

  return
end
function rmdcon ( k )

!*****************************************************************************80
!
!! RMDCON returns machine constants.
!
!
  implicit none

  integer &
     k
  real rmdcon
!
!
  real &
     big,eta,machep,one001,pt999
!
!
!    return machine dependent constants used by nl2sol
!
!     integer k
!
!    the constant returned depends on k...
!
!    k = 1... smallest pos. eta such that -eta exists.
!    k = 2... square root of 1.001*eta.
!    k = 3... unit roundoff = smallest pos. no. machep such
!             that 1 + machep > 1 .and. 1 - machep < 1.
!    k = 4... square root of 0.999*machep.
!    k = 5... square root of 0.999*big (see k = 6).
!    k = 6... largest machine no. big such that -big exists.
!
!
  data one001/1.001e0/, pt999/0.999e0/

  big = huge ( big )
  eta = tiny ( eta )
  machep = epsilon ( machep )

  go to (10, 20, 30, 40, 50, 60), k
!
 10   rmdcon = eta
  go to 999
!
 20   rmdcon = sqrt(one001*eta)
  go to 999
!
 30   rmdcon = machep
  go to 999
!
 40   rmdcon = sqrt(pt999*machep)
  go to 999
!
 50   rmdcon = sqrt(pt999*big)
  go to 999
!
 60   rmdcon = big
!
 999  return
end
subroutine rptmul ( func, ipivot, j, nn, p, rd, x, y, z )

!*****************************************************************************80
!
!! RPTMUL multiplies the R factor times a vector X.
!
!  Discussion:
!
!    This routine computes one of:
!
!      Y = R * P' * X
!      Y = P * R' * R * P' * X
!      Y = P * R' * X.
!
!    where P is a permutation matrix represented by a permutation
!    vector, and R is an upper triangular matrix, the R factor of
!    a QR factorization.
!
!    The strict upper triangle of R is stored in the strict upper triangle
!    of the array J, and the diagonal of R is stored in the vector RD.
!
!    X and Y may share storage.
!
!  Modified:
!
!    10 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer FUNC, determines which product to compute:
!    1, Y =                RMAT * PERM' * X.
!    2, Y = PERM * PERM' * RMAT * PERM' * X.
!    3, Y = PERM *                PERM' * X.
!
!    Input, integer IPIVOT(P), the permutation vector.
!
!    Input, real J(NN,P), contains the strict upper triangle of the
!    matrix RMAT.
!
!    Input, integer NN, the leading dimension of J.
!
!    Input, integer P, the length of X and Y, and the order of RMAT.
!
!    Input, real RD(P), the diagonal elements of the matrix RMAT.
!
!    Input, real X(P), the input vector.
!
!    Output, real Y(P), the output vector.
!
!    Workspace, real Z(P).
!
  implicit none

  integer nn
  integer p

  real dotprd
  integer func
  integer i
  integer ipivot(p)
  real j(nn,p)
  integer k
  real rd(p)
  real x(p)
  real y(p)
  real z(p)
  real zk

  if ( func <= 2 ) then
!
!  Set Z = PERM' * X.
!
    do i = 1, p
      k = ipivot(i)
      z(i) = x(k)
    end do
!
!  Set Y = RMAT * Z.
!
    y(1) = z(1) * rd(1)

    do k = 2, p
      zk = z(k)
      do i = 1, k-1
        y(i) = y(i) + j(i,k) * zk
      end do
      y(k) = zk * rd(k)
    end do

    if ( func <= 1 ) then
      return
    end if

  else

    y(1:p) = x(1:p)

  end if
!
!  Set Z = RMAT' * Y.
!
  z(1) = y(1) * rd(1)

  do i = 2, p
    z(i) = y(i) * rd(i) + dotprd ( i-1, j(1,i), y )
  end do
!
!  Set Y = PERM * Z.
!
  do i = 1, p
    k = ipivot(i)
    y(k) = z(i)
  end do

  return
end
subroutine s88fmt ( n, w, ifmt )

!*****************************************************************************80
!
!! S88FMT writes an integer into a string.
!
!  s88fmt  replaces ifmt(1), ... , ifmt(n) with
!  the characters corresponding to the n least significant
!  digits of w.
!
!
  implicit none

  integer n,w
!
!  array arguments
  character ifmt(n)*4
!
!
  integer idigit,nt,wt
!
!  local arrays
  character digits(10)*4
!
!
  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' /

  nt = n
  wt = w

  do

    if ( nt <= 0 ) then
      exit
    end if

    idigit = mod( wt, 10 )
    ifmt(nt) = digits(idigit+1)
    wt = wt / 10
    nt = nt - 1

  end do

  return
end
subroutine sample ( y, n, ns, ys, nys )

!*****************************************************************************80
!
!! SAMPLE creates a new series by sampling every K-th item of the input.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,ns,nys
!
!  array arguments
  real &
     y(*),ys(*)
!
!  scalars in common
  integer &
     ierr

  logical &
     err01,err02,head
!
!  local arrays
  character &
     ln(8)*1,lns(8)*1,lone(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,eisii,smply
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01, err02
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     character*1 ln(8), lns(8), lone(8)
!        the array containing the name of the variable n and ns.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer ns
!        the sampling rate.
!     integer nys
!        the number of observations in the filtered series ys.
!     real y(n)
!        the vector containing the observed time series.
!     real ys(n)
!        the vector in which the sampled series is returned.
!
!     set up name arrays
!
  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',   ' ',   ' ',   ' ',   ' ',   ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  call eisii(nmsub, lns, ns, 1, n, 1, head, err02, lone, ln)

  if (err01 .or. err02) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call smply (y, n, ns, ys, nys)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call sample (y, n, ns, ys, nys)')
end
function sasum ( n, x, incx )

!*****************************************************************************80
!
!! SASUM takes the sum of the absolute values of a real vector.
!
!  Modified:
!
!    15 February 2001
!
!  Author:
!
!    Jack Dongarra
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector to be examined.
!
!    Input, integer INCX, the increment between successive entries of X.
!    INCX must not be negative.
!
!    Output, real SASUM, the sum of the absolute values of X.
!
  implicit none

  integer incx
  integer n
  real sasum
  real x(*)

  sasum = sum ( abs ( x(1:1+(n-1)*incx:incx) ) )

  return
end
subroutine saxpy ( n, sa, x, incx, y, incy )

!*****************************************************************************80
!
!! SAXPY adds a real constant times one vector to another.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Jack Dongarra
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real SA, the multiplier.
!
!    Input, real X(*), the vector to be scaled and added to Y.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input/output, real Y(*), the vector to which a multiple of X is to
!    be added.
!
!    Input, integer INCY, the increment between successive entries of Y.
!
  implicit none

  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real sa
  real x(*)
  real y(*)

  if ( n <= 0 ) then

  else if ( sa == 0.0E+00 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    y(1:n) = y(1:n) + sa * x(1:n)

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      y(iy) = y(iy) + sa * x(ix)
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
subroutine scopy ( n, x, incx, y, incy )

!*****************************************************************************80
!
!! SCOPY copies one real vector into another.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Jack Dongarra
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector to be copied into Y.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Output, real Y(*), the copy of X.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
  implicit none

  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real x(*)
  real y(*)

  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    y(1:n) = x(1:n)

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      y(iy) = x(ix)
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
function sdot ( n, x, incx, y, incy )

!*****************************************************************************80
!
!! SDOT forms the dot product of two real vectors.
!
!  Modified:
!
!    02 June 2000
!
!  Author:
!
!    Jack Dongarra
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vectors.
!
!    Input, real X(*), one of the vectors to be multiplied.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input, real Y(*), one of the vectors to be multiplied.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
!    Output, real SDOT, the dot product of X and Y.
!
  implicit none

  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real sdot
  real stemp
  real x(*)
  real y(*)

  if ( n <= 0 ) then

    sdot = 0.0E+00

  else if ( incx == 1 .and. incy == 1 ) then

    sdot = dot_product ( x(1:n), y(1:n) )

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    stemp = 0.0E+00
    do i = 1, n
      stemp = stemp + x(ix) * y(iy)
      ix = ix + incx
      iy = iy + incy
    end do

    sdot = stemp

  end if

  return
end
subroutine setesl ( n, ndiv, nfft )

!*****************************************************************************80
!
!! SETESL: smallest suitable value of NFFT for given N and Singleton FFT.
!
!  Discussion:
!
!    this routine computes the smallest value of nfft which
!    equals or exceeds n + 2, such that nfft - 2 is
!    1. divisible by ndiv,
!    2. has no more than 11 prime factors,
!    3. has no prime factor greater than 23, and
!    4. the product of the square free prime factors of
!        (nfft-2)/ndiv do not exceed 210 if ndiv = 2, and
!                                    105 if ndiv = 4.
!    the value of nfft thus meet the requirements of
!    the extended length of the series required for any routine
!    using the singleton fft providing the proper value of ndiv
!    is chosen.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,ndiv,nfft
!
!
  integer &
     i,npf,nsfp
!
!  local arrays
  integer &
     ipf(50),ipfexp(50)
!
!  external subroutines
  external factor
!
!     variable definitions (alphabetically)
!
!     integer i
!       an index variable.
!     integer ipf(50), ipfexp(50)
!        the vectors of prime factors of nfft and their exponents,
!        respectively, where the length of these vectors is
!        sufficient to accomodate the prime factors of an integer
!        up to 2 ** 128 (approximately 10 ** 40).
!     integer n
!        the number upon which nfft is based.
!     integer ndiv
!        a required factor of nfft - 2.
!     integer nfft
!        the returned value which meets the above description.
!     integer npf
!        the number of prime factors in nfft.
!     integer nsfp
!        the product of the non square factors.
!
  nfft = n
  if (nfft <= 0) return
  if (mod(nfft, ndiv)  /=  0) nfft = nfft + ndiv - mod(nfft, ndiv)
  nfft = nfft - ndiv

  do

    nfft = nfft + ndiv
    call factor(nfft/ndiv, npf, ipf, ipfexp)

    if ((npf >= 11) .or. (ipf(npf) > 23)) then
      cycle
    end if

    nsfp = 1
    if (ndiv == 4) nsfp = 2
    do i = 1, npf
      if (mod(ipfexp(i), 2) == 1) nsfp = nsfp * ipf(i)
    end do

    if (nsfp < 210) then
      exit
    end if

  end do

  nfft = nfft + 2

  return
end
subroutine setfrq ( freq, nf, nprt, fmin, fmax, h )

!*****************************************************************************80
!
!! SETFRQ computes the frequencies at which the spectrum is to be estimated.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin,h
  integer &
     nf,nprt
!
!  array arguments
  real &
     freq(nf)
!
!
  real &
     deltaf
  integer &
     i
!
!     variable definitions (alphabetically)
!
!     real deltaf
!        the frequency increment.
!     real fmax, fmin
!        the maximum and minimum frequencies at which the
!        spectrum is to be estimated.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     real h
!        the sampling interval.
!     integer i
!        an indexing variable.
!     integer nf
!        the number of frequencies for which the spectral estimates
!        are to be estimated.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt equals 2 the frequency scale is linear, and if
!        nprt equals 3 the frequency scale is log.
!
!  compute frequency values for linear scale
!
  if ( nprt /= 3) then

    freq(1) = fmin

    if (nf == 1) return

    deltaf = (fmax - fmin) / (h * real (nf - 1))
    do i = 2, nf
      freq(i) = freq(i-1) + deltaf
    end do

    freq(nf) = fmax
!
!  compute frequency values for log scale
!
  else

    deltaf = (log10(fmax) - log10(fmin)) / (h * real (nf - 1))

    freq(1) = fmin

    if (nf == 1) return

    do i = 2, nf
       freq(i) = 10.0e0**(log10(freq(i-1)) + deltaf)
    end do

    freq(nf) = fmax

  end if

  return
end
subroutine setiv ( vector, n, value )

!*****************************************************************************80
!
!! SETIV sets the entries of an integer vector to a value.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer n
!        number of elements to set
!     integer value
!        value to which the elements are to be set
!     integer vector(n)
!        vector whose first n elements are to be set.
!
  implicit none

  integer &
     n,value
!
!  array arguments
  integer &
     vector(n)

  vector(1:n) = value

  return
end
subroutine setlag ( n, lagmax )

!*****************************************************************************80
!
!! SETLAG sets the number of autocorrelations to be computed.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer lagmax
  integer n
!
!     variable definitions (alphabetically)
!
!     integer lagmax
!        the number of lags at which the autocovariances are to be
!        computed.
!     integer n
!        the integer number of observations in each series
!
  if (n  >=  96)                 lagmax = min(n / 3, 100)
  if (33 <= n .and. n <= 95) lagmax = 32
  if (n <= 32)                 lagmax = n - 1

  return
end
subroutine setra ( array, im, m, n, value )

!*****************************************************************************80
!
!! SETRA sets the entries of a real array to a given value.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real array(im,m)
!        array for which elements will be set
!     integer im
!        actual first dimension of array in calling program
!     integer m
!        number of columns to set
!     integer n
!        number of rows to set
!     real value
!        value to which the elements are to be set
!
  implicit none

  real &
     value
  integer &
     im,m,n
!
!  array arguments
  real &
     array(im,m)

  array(1:n,1:m) = value

  return
end
subroutine setrow ( nrow, xm, n, m, ixm, nrowu )

!*****************************************************************************80
!
!! SETROW selects the row used by the derivative checking procedure.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations of data.
!     integer nrow, nrowu
!        the user-supplied number of the row of the independent
!        variable array at which the derivative is to be checked,
!        and the number of the row actually used.
!     real xm(ixm,m)
!        the independent variable matrix.
!
  implicit none

  integer &
     ixm,m,n,nrow,nrowu
!
!  array arguments
  real &
     xm(ixm,m)
!
!
  integer &
     i

  nrowu = nrow

  if ((nrowu >= 1) .and. (nrowu <= n)) return
!
!  select first row of independent variables which contains no zeros
!  if there is one, otherwise first row is used.
!
  do i = 1, n

    if ( any ( xm(i,1:m) == 0.0E+00 ) ) then

    else
      nrowu = i
      return
    end if

  end do

  nrowu = 1

  return
end
subroutine setrv ( vector, n, value )

!*****************************************************************************80
!
!! SETRV sets the elements of a real vector to a value.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer n
!        number of elements to set
!     real value
!        value to which the elements are to be set
!     real vector(n)
!        vector whose first n elements are to be set.
!
  implicit none

  integer n

  real value
  real vector(n)

  vector(1:n) = value

  return
end
subroutine slflt ( y, n, k, h, yf, nyf )

!*****************************************************************************80
!
!! SLFLT applies a symmetric filter to a series.
!
!  Discussion:
!
!    this subroutine performs a symmetric filtering operation
!    on an input series y, returning the filtered series in yf.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     k,n,nyf
!
!  array arguments
  real &
     h(*),y(*),yf(*)
!
!  scalars in common
  integer &
     ierr

  logical &
     err01,err02,err03,err04,head
!
!  local arrays
  character &
     lh(8)*1,lk(8)*1,ln(8)*1,lone(8)*1,nmsub(6)*1
!
!  external subroutines
  external eisge,eisii,eriodd,erslf,fltsl
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01, err02, err03, err04
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     real h(k)
!        the array of symmetric linear filter coefficients.
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer k
!        the number of filter terms.
!     character*1 lh(8), lk(8), ln(8), lone(8)
!        the arrays containing the names of the variables k and n.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nyf
!        the number of observations in the filtered series yf.
!     real y(n)
!        the vector containing the observed time series.
!     real yf(n)
!        the vector in which the filtered series is returned.
!
!     set up name arrays
!
  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', ' ', ' ', ' ', ' ', ' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 3, 1, head, err01, ln)

  call eisii(nmsub, lk, k, 1, n, 1, head, err02, lone, ln)

  call eriodd(nmsub, lk, k, 1, head, err03)

  if (err01 .or. err02 .or. err03) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call erslf(nmsub, lh, k, h, head, err04)

  if ( err04 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call fltsl (y, n, k, h, yf, nyf)

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call slflt (y, n, k, h, yf, nyf)')
end
subroutine slupdt ( a, cosmin, p, size, step, u, w, wchmtd, wscale, y )

!*****************************************************************************80
!
!! SLUPDT updates a symmetric matrix A so that A * STEP = Y.
!
!  Discussion:
!
!    Update the symmetric matrix A so that A * STEP = Y.  Only the lower
!    triangle of A is stored, by rows.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
  implicit none

  integer p

  real a((p*(p+1))/2)
  real cosmin
  real denmin
  real dotprd
  integer i
  integer j
  integer k
  real sdotwm
  real size
  real step(p)
  real t
  real u(p)
  real v2norm
  real w(p)
  real wchmtd(p)
  real wscale
  real y(p)

  sdotwm = dot_product ( step(1:p), wchmtd(1:p) )

  denmin = cosmin * v2norm ( p, step ) * v2norm ( p, wchmtd )

  if ( denmin /= 0.0E+00 ) then
    wscale = min ( 1.0E+00, abs ( sdotwm / denmin ) )
  else
    wscale = 1.0E+00
  end if

  if ( sdotwm /= 0.0E+00 ) then
    t = wscale / sdotwm
  else
    t = 0.0E+00
  end if

  w(1:p) = t * wchmtd(1:p)

  call slvmul ( p, u, a, step )

  t = 0.5E+00 * ( size * dotprd ( p, step, u ) - dotprd ( p, step, y ) )

  u(1:p) = t * w(1:p) + y(1:p) - size * u(1:p)
!
!  Set A = A + U * W' + W * U'.
!
  k = 1
  do i = 1, p
    do j = 1, i
      a(k) = size * a(k) + u(i) * w(j) + w(i) * u(j)
      k = k + 1
    end do
  end do

  return
end
subroutine slvmul ( p, y, s, x )

!*****************************************************************************80
!
!! SLVMUL sets Y = S * X, where S is a P by P symmetric matrix.
!
!  Discussion:
!
!    This routine sets Y = S * X,  where X is a given vector and
!    S is a P by P symmetric matrix.  The lower triangle of S is
!    stored by rows.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer P, the order of S, X and Y.
!
!    Output, real Y(P), the product S * X.
!
!    Input, real S((P*(P+1))/2), the P by P symmetric matrix.  Only the
!    lower triangle is stored, by rows.
!
!    Input, real X(P), the vector to be multiplied by S.
!
  implicit none

  integer p

  integer i
  integer j
  integer k
  real s((p*(p+1))/2)
  real x(p)
  real y(p)
!
!  Compute the lower triangle of S times X.
!
  j = 1
  do i = 1, p
    y(i) = dot_product ( s(j:j+i-1), x(1:i) )
    j = j + i
  end do
!
!  Compute the strict upper triangle of S times X.
!
  j = 1
  do i = 2, p
    j = j + 1
    do k = 1, i - 1
      y(k) = y(k) + s(j) * x(i)
      j = j + 1
    end do
  end do

  return
end
function smach ( job )

!*****************************************************************************80
!
!! SMACH computes machine parameters for single precision arithmetic.
!
!  Discussion:
!
!    Assume the computer has
!
!      B = base of arithmetic;
!      T = number of base B digits;
!      L = smallest possible exponent;
!      U = largest possible exponent;
!
!    then
!
!      EPS = B**(1-T)
!      TINY = 100.0 * B**(-L+T)
!      HUGE = 0.01 * B**(U-T)
!
!  Modified:
!
!    19 February 2006
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for FORTRAN usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, pages 308-323, 1979.
!
!  Parameters:
!
!    Input, integer JOB:
!    1, EPS is desired;
!    2, TINY is desired;
!    3, HUGE is desired.
!
!    Output, real SMACH, the requested value.
!
  implicit none

  real eps
  real huge
  integer job
  real s
  real smach
  real tiny

  eps = 1.0E+00

  do

    eps = eps / 2.0E+00
    s = 1.0E+00 + eps
    if ( s <= 1.0E+00 ) then
      exit
    end if

  end do

  eps = 2.0E+00 * eps

  s = 1.0E+00

  do

    tiny = s
    s = s / 16.0E+00

    if ( s * 1.0E+00 == 0.0E+00 ) then
      exit
    end if

  end do

  tiny = ( tiny / eps ) * 100.0E+00

  huge = 1.0E+00 / tiny

  if ( job == 1 ) then
    smach = eps
  else if ( job == 2 ) then
    smach = tiny
  else if ( job == 3 ) then
    smach = huge
  else
    smach = 0.0E+00
  end if

  return
end
subroutine smply ( y, n, ns, ys, nys )

!*****************************************************************************80
!
!! SMPLY samples every K-th observation from a series.
!
!  Discussion:
!
!    this subroutine samples every kth observation from the input
!    series y, storing the sampled series in ys.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,ns,nys
!
!  array arguments
  real &
     y(n),ys(n)
!
!
  integer &
     i,i1
!
!     variable definitions (alphabetically)
!
!     integer n
!        the number of observations in the series y.
!     integer ns
!        the sampling rate.
!     integer nys
!        the number of observations in the filtered series ys.
!     real y(n)
!        the vector containing the observed time series.
!     real ys(n)
!        the vector in which the sampled series is returned.
!
  nys = 0

  do i = 1, n, ns
     nys = nys + 1
     ys(nys) = y(i)
  end do

  i1 = nys + 1
  ys(i1:n) = 0.0e0

  return
end
function snrm2 ( n, x, incx )

!*****************************************************************************80
!
!! SNRM2 computes the Euclidean norm of a real vector.
!
!  Modified:
!
!    01 June 2000
!
!  Author:
!
!    Sven Hammarling
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector whose norm is to be computed.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Output, real SNRM2, the Euclidean norm of X.
!
  implicit none

  real absxi
  integer incx
  integer ix
  integer n
  real norm
  real scale
  real snrm2
  real  ssq
  real x(*)

  if ( n < 1 .or. incx < 1 ) then

    norm  = 0.0E+00

  else if ( n == 1 ) then

    norm  = abs ( x(1) )

  else

    scale = 0.0E+00
    ssq = 1.0E+00

    do ix = 1, 1 + ( n - 1 )*incx, incx
      if ( x(ix) /= 0.0E+00 ) then
        absxi = abs ( x(ix) )
        if ( scale < absxi ) then
          ssq = 1.0E+00 + ssq * ( scale / absxi )**2
          scale = absxi
        else
          ssq = ssq + ( absxi / scale )**2
        end if
      end if
    end do
    norm  = scale * sqrt( ssq )
  end if

  snrm2 = norm

  return
end
subroutine spcck ( spc, isort, nf, spcmn, spcmx, nspc, ispcer )

!*****************************************************************************80
!
!! SPCCK analyzes ordinates for the spectal semi-log plots.
!
!  Discussion:
!
!    this routine analyzes the ordinates for the spectral semi log
!    plots produced by the aspc series of routines.  y axis values
!    (yord) more than 3 powers of ten less than the next larger
!    value are considered insignificant and are culled from the
!    ordinates.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     spcmn,spcmx
  integer &
     ispcer,nf,nspc
!
!  array arguments
  real &
     spc(nf)
  integer &
     isort(nf)
!
!
  integer &
     i,k1,k2,log1,log2
!
!  external subroutines
  external srtir,srtri
!
!     variable definitions (alphabetically)
!
!     integer i
!        an index variable
!     integer isort(nf)
!        the array in which the order permutation for the sorted
!        data is stored.
!     integer ispcer
!        an indicator variable used to supress the spectral plots
!        when fewer than 1 valid spectral values were computed.
!     integer k1, k2
!        index variables.
!     integer log1, log2
!        the order of the spectral estimates.
!     integer nf
!        the number of frequencies for which the spectral estimates
!        are to be estimated.
!     integer nspc
!        the number of valid spectral estimates.
!     real spc(nf)
!        the array containing the spectral estimates.
!     real spcmn, spcmx
!        the minimum and maximum spectral value to be plotted.
!
!  order the spectral estimates from smallest to largest.
!
  do i = 1, nf
     isort(i) = i
  end do
  call srtir (isort, nf, spc)
!
!  determine significant values to be plotted.
!
  k1 = nf
  k2 = k1
  if ((spc(nf) <= 0.0e0) .or. (nf == 1)) go to 30
  log1 = int ( log10(spc(nf)) )
  if (spc(nf) < 1.0e0) log1 = log1 - 1

  do i = 2, nf

     k2 = k1 - 1

     if (spc(k2) <= 0.0e0) then
       exit
     end if

     log2 = int ( log10(spc(k2)) )

     if (spc(k2) < 1.0e0) then
       log2 = log2 - 1
     end if

     if (log1-log2  >=  3 .and. nf-k2  >=  5) then
       exit
     end if

     log1 = log2
     k1 = k2

  end do

   30 continue

  spcmn = spc(k1)
  nspc = nf + 1 - k1

  spcmx = spc(nf)

  call srtri (spc, nf, isort)
  ispcer = 0
  if (nf-k2 <= 0) ispcer = 1

  return
end
subroutine sppc ( ym, x, n, isym, ilog, isize, nout, ylb, yub, &
    xlb, xub )

!*****************************************************************************80
!
!! SPPC: simple page plot with user control of plot symbols (long call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xlb,xub,ylb,yub
  integer &
     ilog,isize,n,nout
!
!  array arguments
  real &
     x(*),ym(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xmiss
  integer &
     ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'p',       'p',       'c',       ' ',       ' '/

  ymmiss(1) = 1.0e0
  xmiss = 1.0e0
  m = 1
  iym = n
  multi = .false.
  ischck = 1
  miss = .false.
  lisym = n

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call sppc (y, x, n, isym, ilog,'/ &
    '      +           isize, nout, ylb, yub, xlb, xub)')
end
subroutine spp ( ym, x, n, isym )

!*****************************************************************************80
!
!! SPP: simple page plot with user control of plot symbols (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     x(*),ym(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  character &
     nmsub(6)*1
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!     the labeled common for communicating error flags to the user
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'p',       'p',       ' ',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call spp (y, x, n, isym)')
end
subroutine sppl ( ym, x, n, isym, ilog )

!*****************************************************************************80
!
!! SPPL: simple page plot with user control of plot symbols (log option).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ilog,n
!
!  array arguments
  real &
     x(*),ym(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'p',       'p',       'l',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if ( ierr /= 0 ) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call sppl (y, x, n, isym, ilog)')
end
subroutine sppltc ( xaxis, yaxis, isym, npts, xpltmn, xpltmx, bw, &
     cilow, cimid, ciup, lpcv )

!*****************************************************************************80
!
!! SPPLTC: confidence interval and bandwidth coordinates for spectrum plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     bw,cilow,cimid,ciup,xpltmn,xpltmx
  integer &
     lpcv,npts
!
!  array arguments
  real &
     xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)
!
!     variable definitions (alphabetically)
!
!     real bw
!       the bandwidth.
!     real cilow, cimid, ciup
!        the y cordnates for the lower  mid and upper confidence
!        interval points.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lpcv
!        the length of the vectors used for the plots.
!     integer npts
!        the number of coordinates to be plotted.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plot.
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plots.
!
  if (xpltmx - xpltmn < bw) then

    xpltmx = max(xpltmx + (bw - xpltmx + xpltmn) / 2.0e0, 0.5e0)
    xpltmn = xpltmx - bw

  end if

  npts = npts + 1

  xaxis(npts) = xpltmx - 0.5e0 * bw
  yaxis(npts) = ciup
  isym(npts) = 7

  npts = npts + 1

  xaxis(npts) = xpltmx - 0.5e0 * bw
  yaxis(npts) = cimid
  isym(npts) = 3

  npts = npts + 1

  xaxis(npts) = xpltmx - 0.5e0 * bw
  yaxis(npts) = cilow
  isym(npts) = 13

  npts = npts + 1

  xaxis(npts) = xpltmx - bw
  yaxis(npts)  = cimid
  isym(npts) = 6

  npts = npts + 1

  xaxis(npts) = xpltmx
  yaxis(npts)  = cimid
  isym(npts) = 27

  return
end
subroutine sppltd ( spcmn, spcmx, alow, aup, ypltmn, ypltmx, &
     cilow, cimid, ciup, ymax )

!*****************************************************************************80
!
!! SPTLTD sets various y axis limits for decibel spectrum plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     alow,aup,cilow,cimid,ciup,spcmn,spcmx,ymax,ypltmn,ypltmx

  real &
     rngmn,ymin
!
!     variable definitions (alphabetically)
!
!     real alow, aup
!        factors used to compute the confidence intervals.
!     real cilow, cimid, ciup
!        the y coordnates for the lower  mid and upper confidence
!        interval points.
!     real rngmn
!        the minimum y axis range for the plot.
!     real spcmn, spcmx
!        the minimum and maximum spectral value to be plotted.
!     real ymax, ymin
!        the maximum and minimum actual spectral value
!        (in decibels) to be plotted.
!     real ypltmn, ypltmx
!        the minimum and maximum vaues to be plotted for the y axis.
!
!  set coordinates for decibel plots
!
  ymax = 10.0e0 * log10(spcmx)
  ymin = 10.0e0 * log10(spcmn) - ymax

  ypltmx = 0.0e0
  rngmn = 20.0e0 * (log10(aup) - log10(alow))
  if (abs(ymin) < rngmn) ypltmx = (rngmn + ymin) * 0.5e0
  ypltmn = ymin - ypltmx
  ciup = ypltmx
  cimid = ciup - 10.0e0 * log10(aup)
  cilow = cimid + 10.0e0 * log10(alow)

  return
end
subroutine sppltl ( spcmn, spcmx, alow, aup, ypltmn, ypltmx, cilow, cimid, &
  ciup )

!*****************************************************************************80
!
!! SPPLTL sets various y axis limits for decibel spectrum plots.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     alow,aup,cilow,cimid,ciup,spcmn,spcmx,ypltmn,ypltmx

  real &
     rngmn,ymax,ymin
!
!     variable definitions (alphabetically)
!
!     real alow, aup
!        factors used to compute the confidence intervals.
!     real cilow, cimid, ciup
!        the y cordnates for the lower  mid and upper confidence
!        interval points.
!     real rngmn
!        the minimum y axis range for the plot.
!     real spcmn, spcmx
!        the minimum and maximum spectral value to be plotted.
!     real ymax, ymin
!        the maximum and minimum actual spectrum value to be plotted.
!     real ypltmn, ypltmx
!        the minimum and maximum vaues to be plotted for the y axis.
!
!     set coordinates for decibel plots
!
  ymax = log10(spcmx)
  ymin = log10(spcmn)

  ypltmx = spcmx
  ypltmn = spcmn
  rngmn = 2.0e0 * (log10(aup) - log10(alow))

  if (ymax - ymin < rngmn) then

    ypltmx = 10.0e0 ** (ymax + (rngmn - ymax + ymin) * 0.5e0)
    ypltmn = 10.0e0 ** (ymin - (rngmn - ymax + ymin) * 0.5e0)

  end if

  ciup = ypltmx
  cimid = ciup / aup
  cilow = cimid * alow

  return
end
subroutine sppmc ( ym, ymmiss, x, xmiss, n, isym, ilog, isize, nout, &
     ylb, yub, xlb, xub )

!*****************************************************************************80
!
!! SPPMC: page plot with user plot symbols and missing observations (long call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xlb,xmiss,xub,ylb,yub
  integer &
     ilog,isize,n,nout
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(1)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'p',       'p',       'm',       'c',       ' '/

  m = 1
  iym = n
  multi = .false.
  ischck = 1
  miss = .true.
  lisym = n

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call sppmc (y, ymiss, x, xmiss, n, isym, ilog,'/ &
     '      +            isize, nout, ylb, yub, xlb, xub)')
end
subroutine sppm ( ym, ymmiss, x, xmiss, n, isym )

!*****************************************************************************80
!
!! SPPM page plot with user plot symbols and missing observations (short call).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xmiss
  integer &
     n
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(1)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xub,ylb,yub
  integer &
     ilog,ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'p',       'p',       'm',       ' ',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call sppm (y, ymiss, x, xmiss, n, isym)')
end
subroutine sppml ( ym, ymmiss, x, xmiss, n, isym, ilog )

!*****************************************************************************80
!
!! SPPML: page plot with user plot symbols, missing observations (log option).
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, Linda Mitchell,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xmiss
  integer &
     ilog,n
!
!  array arguments
  real &
     x(*),ym(*),ymmiss(1)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xlb,xub,ylb,yub
  integer &
     ischck,isize,iym,lisym,m,nout
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external ppcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbols for plotting.
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nout
!        used to indicate how many of the points outside the bounds
!        of the plot are to be listed.
!     real x(n)
!        vector of observations for x coordinates
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real xmiss
!        the missing value code for the x-axis.
!     real xub
!        the upper bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(n,1)
!        vector of observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'p',       'p',       'm',       'l',       ' '/

  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

  call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, &
    ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, &
    lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call sppml (y, ymiss, x, xmiss, n, isym, ilog)')
end
subroutine srot ( n, x, incx, y, incy, c, s )

!*****************************************************************************80
!
!! SROT applies a real plane rotation.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Jack Dongarra
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vectors.
!
!    Input/output, real X(*), one of the vectors to be rotated.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input/output, real Y(*), one of the vectors to be rotated.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
!    Input, real C, S, parameters (presumably the cosine and sine of
!    some angle) that define a plane rotation.
!
  implicit none

  real c
  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real s
  real stemp
  real x(*)
  real y(*)

  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    do i = 1, n
      stemp = c * x(i) + s * y(i)
      y(i) = c * y(i) - s * x(i)
      x(i) = stemp
    end do

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      stemp = c * x(ix) + s * y(iy)
      y(iy) = c * y(iy) - s * x(ix)
      x(ix) = stemp
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
subroutine srotg ( sa, sb, c, s )

!*****************************************************************************80
!
!! SROTG constructs a real Givens plane rotation.
!
!  Discussion:
!
!    Given values A and B, this routine computes
!
!    SIGMA = sign ( A ) if abs ( A ) >  abs ( B )
!          = sign ( B ) if abs ( A ) <= abs ( B );
!
!    R     = SIGMA * ( A * A + B * B );
!
!    C = A / R if R is not 0
!      = 1     if R is 0;
!
!    S = B / R if R is not 0,
!        0     if R is 0.
!
!    The computed numbers then satisfy the equation
!
!    (  C  S ) ( A ) = ( R )
!    ( -S  C ) ( B ) = ( 0 )
!
!    The routine also computes
!
!    Z = S     if abs ( A ) > abs ( B ),
!      = 1 / C if abs ( A ) <= abs ( B ) and C is not 0,
!      = 1     if C is 0.
!
!    The single value Z encodes C and S, and hence the rotation:
!
!    If Z = 1, set C = 0 and S = 1;
!    If abs ( Z ) < 1, set C = sqrt ( 1 - Z * Z ) and S = Z;
!    if abs ( Z ) > 1, set C = 1/ Z and S = sqrt ( 1 - C * C );
!
!  Modified:
!
!    15 May 2006
!
!  Author:
!
!    Jack Dongarra
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input/output, real SA, SB.  On input, SA and SB are the values
!    A and B.  On output, SA is overwritten with R, and SB is
!    overwritten with Z.
!
!    Output, real C, S, the cosine and sine of the Givens rotation.
!
  implicit none

  real c
  real r
  real roe
  real s
  real sa
  real sb
  real scale
  real z

  if ( abs ( sb ) < abs ( sa ) ) then
    roe = sa
  else
    roe = sb
  end if

  scale = abs ( sa ) + abs ( sb )

  if ( scale == 0.0E+00 ) then
    c = 1.0E+00
    s = 0.0E+00
    r = 0.0E+00
  else
    r = scale * sqrt ( ( sa / scale )**2 + ( sb / scale )**2 )
    r = sign ( 1.0E+00, roe ) * r
    c = sa / r
    s = sb / r
  end if

  if ( 0.0E+00 < abs ( c ) .and. abs ( c ) <= s ) then
    z = 1.0E+00 / c
  else
    z = s
  end if

  sa = r
  sb = z

  return
end
subroutine srtir ( ir, la, a )

!*****************************************************************************80
!
!! SRTIR sorts an integer array IR on a key array A.
!
!  Discussion:
!
!    sort integer array ir on key array a.
!    if the integer array consists of the
!    ordered sequence 1, 2, ... la, then
!    on completion ir is  a permutation
!    vector for the sort of a.
!
!  Parameters:
!
!    a(la)  - on input, contains the array to be sorted on
!                         on output, a contains the sorted array
!                la     - input variable containing the number of
!                           elements in the array to be sorted
!                ir(la) - if on input, ir contains the integer values
!                           1,2,...,la.
!                       - then on output, ir contains a record of the
!                           permutations made on the vector a.
!
!
  implicit none

  integer &
     la
!
!  array arguments
  real &
     a(la)
  integer &
     ir(la)

  real &
     r,t,tt
  integer &
     i,ij,it,itt,j,k,l,m
!
!  local arrays
  integer &
     il(21),iu(21)

  m = 1
  i = 1
  j = la
  r = .375e0
   10 if (i == j) go to 90
  if (r > 0.5898437e0) go to 20
  r = r + 3.90625e-2
  go to 30
   20 r = r - .21875e0
   30 k = i
!
!  select a central element of the array and save it in location t.
!
  ij = i + int(real(j-i)*r)
  t = a(ij)
  it = ir(ij)
!
!  if first element of array is greater than t, interchange with t.
!
  if ( t < a(i) ) then
    a(ij) = a(i)
    a(i) = t
    t = a(ij)
    ir(ij) = ir(i)
    ir(i) = it
    it = ir(ij)
  end if

  l = j
!
!  if last element of array is less than t, interchange with t
!
  if (a(j) >= t) go to 60
  a(ij) = a(j)
  a(j) = t
  t = a(ij)
  ir(ij) = ir(j)
  ir(j) = it
  it = ir(ij)
!
!  if first element of array is greater than t, interchange with t
!
  if (a(i) <= 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 continue

  tt = a(l)
  a(l) = a(k)
  a(k) = tt
  itt = ir(l)
  ir(l) = ir(k)
  ir(k) = itt

  60 continue
!
!  find an element in the second half of the array which is smaller than t.
!
  do

    l = l - 1

    if ( a(l) <= t ) then
      exit
    end if

  end do
!
!  find an element in the first half of the array which is greater than t.
!
   70 continue

  k = k + 1

  if (a(k)<t) then
    go to 70
  end if
!
!  interchange these elements
!
  if (k <= l) go to 50
!
!  save upper and lower subscripts of the array yet to be sorted
!
  if ( j-k < l-i ) then
    il(m) = i
    iu(m) = l
    i = k
    m = m + 1
  else
    il(m) = k
    iu(m) = j
    j = l
    m = m + 1
  end if

  go to 100
!
!  begin again on another portion of the unsorted array.
!
   90 continue

  m = m - 1
  if (m == 0) return
  i = il(m)
  j = iu(m)

  100 continue

  if (j-i >= 1) go to 30
  if (i == 1) go to 10
  i = i - 1

  110 continue

  i = i + 1
  if (i == j) go to 90
  t = a(i+1)
  it = ir(i+1)
  if (a(i) <= t) go to 110
  k = i

  do

    a(k+1) = a(k)
    ir(k+1) = ir(k)
    k = k - 1

    if ( a(k) <= t ) then
      exit
    end if

  end do

  a(k+1) = t
  ir(k+1) = it
  go to 110
end
subroutine srtirr ( ir, rr, la, a )

!*****************************************************************************80
!
!! SRTIRR sorts arrays A, IR and RR based on values in A.
!
!  Discussion:
!
!    this routine sorts the length la array a, the length la
!    integer array ir, and the length la array rr into
!    ascending order, based on the values in a.  the array
!    a constitutes the sorting key.  the other two arrays are
!    carried along.  ordinarily the array ir contains the
!    values 1, ..., la initially, so that the three arrays can
!    later be sorted again with ir as the key, in order to
!    restore a and rr to their original order.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     la
!
!  array arguments
  real &
     a(la),rr(la)
  integer &
     ir(la)
!
!
  real &
     r,rt,rtt,t,tt
  integer &
     i,ij,it,itt,j,k,l,m
!
!  local arrays
  integer &
     il(21),iu(21)
!
!     variable definitions (alphabetically)
!
!     real a(la)
!        input/output parameter.  the key array.
!     integer ir(la)
!        input/output parameter.  the integer array carried along
!        in the sort.  initially it should contain 1, ..., la.
!        on exit it contains the permutation vector of the sort.
!        sorting on the permutation vector will restore the key
!        array a and the array rr to their original orders.
!     integer la
!        input parameter.  the length of the input/output parameters
!        a, ir, and rr.
!     real rr(la)
!        input/output parameter.  the array carried along in
!        the sort.  it might be the set of weights for a.
!
  m = 1
  i = 1
  j = la
  r = .375e0
   10 if (i == j) go to 90
  if (r > 0.5898437e0) go to 20
  r = r + 3.90625e-2
  go to 30
   20 r = r - .21875e0
   30 k = i
!
!  select a central element of the array and save it in location t.
!
  ij = i + int(real(j-i)*r)
  t = a(ij)
  it = ir(ij)
  rt = rr(ij)
!
!  if first element of array is greater than t, interchange with t.
!
  if (a(i) <= 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
!
!  if last element of array is less than t, interchange with t
!
  if (a(j) >= 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)
!
!  if first element of array is greater than t, interchange with t
!
  if (a(i) <= 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
!
!  find an element in the second half of the array which is smaller than t.
!
   60 l = l - 1
  if (a(l) > t) go to 60
!
!  find an element in the first half of the array which is greater than t
!
   70 k = k + 1
  if (a(k)<t) go to 70
!
!  interchange these elements
!
  if (k <= l) go to 50
!
!  save upper and lower subscripts of the array yet to be sorted
!
  if (l-i <= 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
!
!  begin again on another portion of the unsorted array
!
   90 m = m - 1
  if (m == 0) return
  i = il(m)
  j = iu(m)
  100 if (j-i >= 1) go to 30
  if (i == 1) go to 10
  i = i - 1
  110 i = i + 1
  if (i == j) go to 90
  t = a(i+1)
  it = ir(i+1)
  rt = rr(i+1)
  if (a(i) <= 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<a(k)) go to 120
  a(k+1) = t
  ir(k+1) = it
  rr(k+1) = rt
  go to 110
end
subroutine srtri ( a, la, ir )

!*****************************************************************************80
!
!! SRTRI sorts array A on integer array IR.
!
!  Discussion:
!
!    This routine sorts array A on an integer array IR.
!    if the integer array is a permutation
!    vector for the array, then the
!    array is restored to its original
!    (unpermuted) order.
!    permutations returned
!
!  Modified:
!
!    30 April 2006
!
!  Parameters:
!
!   a(la)  - on input, contains the array to be sorted
!                         on output, a contains the sorted array
!                la     - input variable containing the number of
!                           elements in the array to be sorted
!                ir(la) - on input, contains the integer key array
!                         on output, contains the sorted key array
!                           1,2,...,la.
!                       - then on output, ir contains a record of the
!                           permutations made on the vector a.
!
!
  implicit none

  integer &
     la
!
!  array arguments
  real &
     a(la)
  integer &
     ir(la)
!
  real &
     r,t,tt
  integer &
     i,ij,it,itt,j,k,l,m
!
!  local arrays
  integer &
     il(21),iu(21)

  m = 1
  i = 1
  j = la
  r = 0.375e0
   10 if (i == j) go to 90
  if (r > 0.5898437e0) go to 20
  r = r + 3.90625e-2
  go to 30
   20 r = r - .21875e0
   30 k = i
!
!  select a central element of the
!  array and save it in location it
!
  ij = i + int(real(j-i)*r)
  t = a(ij)
  it = ir(ij)
!
!  if first element of array is greater
!  than it, interchange with it
!
  if (ir(i) <= 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
!
!  if last element of array is less than it, interchange with it.
!
  if (ir(j) >= it) go to 60
  a(ij) = a(j)
  a(j) = t
  t = a(ij)
  ir(ij) = ir(j)
  ir(j) = it
  it = ir(ij)
!
!  if first element of array is greater than it, interchange with it.
!
  if (ir(i) <= 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
!
!  find an element in the second half of the array which is smaller than it.
!
   60 l = l - 1
  if (ir(l) > it) go to 60
!
!  find an element in the first half of the array which is greater than it.
!
   70 k = k + 1
  if (ir(k)<it) go to 70
!
!  interchange these elements.
!
  if (k <= l) go to 50
!
!  save upper and lower subscripts of the array yet to be sorted.
!
  if (l-i <= 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
!
!  begin again on another portion of
!  the unsorted array.
!
   90 m = m - 1
  if (m == 0) return
  i = il(m)
  j = iu(m)
  100 if (j-i >= 1) go to 30
  if (i == 1) go to 10
  i = i - 1
  110 i = i + 1
  if (i == j) go to 90
  t = a(i+1)
  it = ir(i+1)
  if (ir(i) <= it) go to 110
  k = i
  120 a(k+1) = a(k)
  ir(k+1) = ir(k)
  k = k - 1
  if (it<ir(k)) go to 120
  a(k+1) = t
  ir(k+1) = it
  go to 110
end
subroutine srtrri ( a, rr, la, ir )

!*****************************************************************************80
!
!! SRTRRI sorts the array IR, A and RR, based on values in IR.
!
!  Discussion:
!
!    this routine sorts the length la integer array ir, the length la
!    array a, and the length la array rr into ascending
!    order, based on the values in ir.  the integer array ir
!    constitutes the key.  the other arrays are carried along.
!    ordinarily the array ir contains the permutation vector
!    resulting from an application of the routine srtirr, so that
!    sorting on ir restores a to the order that it had before
!    srtirr was applied.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     la
!
!  array arguments
  real &
     a(la),rr(la)
  integer &
     ir(la)
!
!
  real &
     r,rt,rtt,t,tt
  integer &
     i,ij,it,itt,j,k,l,m
!
!  local arrays
  integer &
     il(21),iu(21)
!
!     variable definitions (alphabetically)
!
!     real a(la)
!        input/output parameter.  the array to be sorted on
!        the basis of the values in ir.  if ir is a permutation
!        vector produced originally in a sort of a, then this
!        operation restores a to its original order.
!     integer ir(la)
!        input/output parameter.  the integer key array.  ordinarily
!        it will be a permutation vector produced by some previous
!        sort of a and rr on a, so that sorting on ir will restore
!        a to its original order.
!     integer la
!        input parameter.  the length of the input/output parameters
!        a, rr, and ir.
!     real rr(la)
!        input/output parameter.  the array carried along in
!        the sort.  it might be the set of weights for a.
!
  m = 1
  i = 1
  j = la
  r = .375e0
   10 if (i == j) go to 90
  if (r > 0.5898437e0) go to 20
  r = r + 3.90625e-2
  go to 30
   20 r = r - 0.21875e0
   30 k = i
!
!  select a central element of the array and save it in location it.
!
  ij = i + int ( real (j-i) * r )
  t = a(ij)
  it = ir(ij)
  rt = rr(ij)
!
!  if first element of array is greater than it, interchange with it.
!
  if (ir(i) <= 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
!
!  if last element of array is less than it, interchange with it.
!
  if (ir(j) >= 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)
!
!  if first element of array is greater than it, interchange with it.
!
  if (ir(i) <= 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 continue

  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
!
!  find an element in the second half of the array which is smaller than it.
!
   60 l = l - 1
  if (ir(l) > it) go to 60
!
!  find an element in the first half of the array which is greater than it.
!
   70 k = k + 1
  if (ir(k)<it) go to 70
!
!  interchange these elements.
!
  if (k <= l) go to 50
!
!  save upper and lower subscripts of the array yet to be sorted.
!
  if (l-i <= 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
!
!  begin again on another portion of the unsorted array
!
   90 m = m - 1
  if (m == 0) return
  i = il(m)
  j = iu(m)
  100 if (j-i >= 1) go to 30
  if (i == 1) go to 10
  i = i - 1

  110 continue

  i = i + 1
  if (i == j) go to 90
  t = a(i+1)
  it = ir(i+1)
  rt = rr(i+1)
  if (ir(i) <= it) go to 110
  k = i
  120 continue

  a(k+1) = a(k)
  ir(k+1) = ir(k)
  rr(k+1) = rr(k)
  k = k - 1
  if (it < ir(k)) go to 120
  a(k+1) = t
  ir(k+1) = it
  rr(k+1) = rt
  go to 110

end
subroutine sscal ( n, sa, x, incx )

!*****************************************************************************80
!
!! SSCAL scales a real vector by a constant.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Jack Dongarra
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real SA, the multiplier.
!
!    Input/output, real X(*), the vector to be scaled.
!
!    Input, integer INCX, the increment between successive entries of X.
!
  implicit none

  integer i
  integer incx
  integer ix
  integer m
  integer n
  real sa
  real x(*)

  if ( n <= 0 ) then

  else if ( incx == 1 ) then

    m = mod ( n, 5 )

    x(1:m) = sa * x(1:m)

    do i = m+1, n, 5
      x(i)   = sa * x(i)
      x(i+1) = sa * x(i+1)
      x(i+2) = sa * x(i+2)
      x(i+3) = sa * x(i+3)
      x(i+4) = sa * x(i+4)
    end do

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    do i = 1, n
      x(ix) = sa * x(ix)
      ix = ix + incx
    end do

  end if

  return
end
subroutine ssidi ( a, lda, n, kpvt, det, inert, work, job )

!*****************************************************************************80
!
!! SSIDI computes the determinant, inertia, inverse of a real symmetric matrix.
!
!  Discussion:
!
!    SSIDI uses the factors from SSIFA.
!
!    A division by zero may occur if the inverse is requested
!    and SSICO has set RCOND == 0.0E+00 or SSIFA has set INFO /= 0.
!
!    Variables not requested by JOB are not used.
!
!  Modified:
!
!    02 March 2006
!
!  Author:
!
!    FORTRAN90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, (Society for Industrial and Applied Mathematics),
!    3600 University City Science Center,
!    Philadelphia, PA, 19104-2688.
!    ISBN 0-89871-172-X
!
!  Parameters:
!
!    Input/output, real A(LDA,N).  On input, the output from SSIFA.
!    On output, the upper triangle of the inverse of the original matrix.
!    The strict lower triangle is never referenced.
!
!    Input, integer LDA, the leading dimension of the array A.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer KPVT(N), the pivot vector from SSIFA.
!
!    Output, real DET(2), the determinant of the original matrix,
!    if requested.
!      determinant = DET(1) * 10.0**DET(2)
!    with 1.0E+00 <= abs ( DET(1) ) < 10.0E+00 or DET(1) = 0.0.
!
!    Output, integer INERT(3), the inertia of the original matrix.
!    INERT(1) = number of positive eigenvalues.
!    INERT(2) = number of negative eigenvalues.
!    INERT(3) = number of zero eigenvalues.
!
!    Workspace, real WORK(N).
!
!    Input, integer JOB, specifies the tasks.
!    JOB has the decimal expansion ABC where
!    If C /= 0, the inverse is computed,
!    If B /= 0, the determinant is computed,
!    If A /= 0, the inertia is computed.
!    For example, JOB = 111 gives all three.
!
  implicit none

  integer lda
  integer n

  real a(lda,n)
  real ak
  real akkp1
  real akp1
  real d
  real det(2)
  logical dodet
  logical doert
  logical doinv
  integer inert(3)
  integer j
  integer jb
  integer job
  integer k
  integer kpvt(n)
  integer ks
  integer kstep
  real sdot
  real t
  real temp
  real, parameter :: ten = 10.0E+00
  real work(n)

  doinv = mod ( job,   10 )       /= 0
  dodet = mod ( job,  100 ) /  10 /= 0
  doert = mod ( job, 1000 ) / 100 /= 0

  if ( dodet .or. doert ) then

    if ( doert ) then
      inert(1:3) = 0
    end if

    if ( dodet ) then
      det(1) = 1.0E+00
      det(2) = 0.0E+00
    end if

    t = 0.0E+00

    do k = 1, n

      d = a(k,k)
!
!  2 by 2 block.
!
!  use det (d  s)  =  (d/t * c - t) * t,  t = abs ( s )
!          (s  c)
!  to avoid underflow/overflow troubles.
!
!  Take two passes through scaling.  Use T for flag.
!
      if ( kpvt(k) <= 0 ) then

        if ( t == 0.0E+00 ) then
          t = abs ( a(k,k+1) )
          d = ( d / t ) * a(k+1,k+1) - t
        else
          d = t
          t = 0.0E+00
        end if

      end if

      if ( doert ) then
        if ( 0.0E+00 < d ) then
          inert(1) = inert(1) + 1
        else if ( d < 0.0E+00 ) then
          inert(2) = inert(2) + 1
        else if ( d == 0.0E+00 ) then
          inert(3) = inert(3) + 1
        end if
      end if

      if ( dodet ) then

        det(1) = d * det(1)

        if ( det(1) /= 0.0E+00 ) then

          do while ( abs ( det(1) ) < 1.0E+00 )
            det(1) = ten * det(1)
            det(2) = det(2) - 1.0E+00
          end do

          do while ( ten <= abs ( det(1) ) )
            det(1) = det(1) / ten
            det(2) = det(2) + 1.0E+00
          end do

        end if

      end if

    end do

  end if
!
!  Compute inverse(A).
!
  if ( doinv ) then

    k = 1

    do while ( k <= n )

      if ( 0 <= kpvt(k) ) then
!
!  1 by 1.
!
        a(k,k) = 1.0E+00 / a(k,k)

        if ( 2 <= k ) then

          work(1:k-1) = a(1:k-1,k)

          do j = 1, k-1
            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 )
          end do

          a(k,k) = a(k,k) + sdot ( k-1, work, 1, a(1,k), 1 )

        end if

        kstep = 1
!
!  2 by 2.
!
      else

        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.0E+00 )
        a(k,k) = akp1 / d
        a(k+1,k+1) = ak / d
        a(k,k+1) = -akkp1 / d

        if ( 2 <= k ) then

          work(1:k-1) = a(1:k-1,k+1)

          do j = 1, k-1
            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 )
          end do

          a(k+1,k+1) = a(k+1,k+1) + sdot ( k-1, work, 1, a(1,k+1), 1 )
          a(k,k+1) = a(k,k+1) + sdot ( k-1, a(1,k), 1, a(1,k+1), 1 )

          work(1:k-1) = a(1:k-1,k)

          do j = 1, k-1
            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 )
          end do

          a(k,k) = a(k,k) + sdot ( k-1, work, 1, a(1,k), 1 )

        end if

        kstep = 2

      end if
!
!  Swap.
!
      ks = abs ( kpvt(k) )

      if ( ks /= k ) then

        call sswap ( ks, a(1,ks), 1, a(1,k), 1 )

        do jb = ks, k
          j = k + ks - jb
          temp = a(j,k)
          a(j,k) = a(ks,j)
          a(ks,j) = temp
        end do

        if ( kstep /= 1 ) then
          temp = a(ks,k+1)
          a(ks,k+1) = a(k,k+1)
          a(k,k+1) = temp
        end if

      end if

      k = k + kstep

    end do

  end if

  return
end
subroutine ssifa ( a, lda, n, kpvt, info )

!*****************************************************************************80
!
!! SSIFA factors a real symmetric matrix.
!
!  Discussion:
!
!    To solve A*X = B, follow SSIFA by SSISL.
!
!    To compute inverse(A)*C, follow SSIFA by SSISL.
!
!    To compute determinant(A), follow SSIFA by SSIDI.
!
!    To compute inertia(A), follow SSIFA by SSIDI.
!
!    To compute inverse(A), follow SSIFA by SSIDI.
!
!  Modified:
!
!    02 March 2006
!
!  Author:
!
!    FORTRAN90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, (Society for Industrial and Applied Mathematics),
!    3600 University City Science Center,
!    Philadelphia, PA, 19104-2688.
!    ISBN 0-89871-172-X
!
!  Parameters:
!
!    Input/output, real A(LDA,N).  On input, the symmetric matrix
!    to be factored.  Only the diagonal and upper triangle are used.
!    On output, a block diagonal matrix and the multipliers which
!    were used to obtain it.  The factorization can be written A = U*D*U'
!    where U is a product of permutation and unit upper triangular
!    matrices, U' is the transpose of U, and D is block diagonal
!    with 1 by 1 and 2 by 2 blocks.
!
!    Input, integer LDA, the leading dimension of the array A.
!
!    Input, integer N, the order of the matrix.
!
!    Output, integer KPVT(N), the pivot indices.
!
!    Output, integer INFO, error flag.
!    0, normal value.
!    K, if the K-th pivot block is singular.  This is not an error
!    condition for this subroutine, but it does indicate that SSISL
!    or SSIDI may divide by zero if called.
!
  implicit none

  integer lda
  integer n

  real a(lda,n)
  real absakk
  real ak
  real akm1
  real alpha
  real bk
  real bkm1
  real colmax
  real denom
  integer imax
  integer info
  integer isamax
  integer j
  integer jj
  integer jmax
  integer k
  integer kpvt(n)
  integer kstep
  real mulk
  real mulkm1
  real rowmax
  logical swap
  real t
!
!  ALPHA is used in choosing pivot block size.
!
  alpha = ( 1.0E+00 + sqrt ( 17.0E+00 ) ) / 8.0E+00

  info = 0
!
!  Main loop on K, which goes from N to 1.
!
  k = n

  do while ( 0 < k )

    if ( k == 1 ) then
      kpvt(1) = 1
      if ( a(1,1) == 0.0E+00 ) then
        info = 1
      end if
      return
    end if
!
!  This section of code determines the kind of
!  elimination to be performed.  When it is completed,
!  KSTEP will be set to the size of the pivot block, and
!  SWAP will be set to .true. if an interchange is required.
!
    absakk = abs ( a(k,k) )
!
!  Determine the largest off-diagonal element in column K.
!
    imax = isamax ( k-1, a(1,k), 1 )
    colmax = abs ( a(imax,k) )

    if ( alpha * colmax <= absakk ) then

      kstep = 1
      swap = .false.
!
!  Determine the largest off-diagonal element in row IMAX.
!
    else

      rowmax = 0.0E+00

      do j = imax+1, k
        rowmax = max ( rowmax, abs ( a(imax,j) ) )
      end do

      if ( imax /= 1 ) then
        jmax = isamax ( imax-1, a(1,imax), 1 )
        rowmax = max ( rowmax, abs ( a(jmax,imax) ) )
      end if

      if ( alpha * rowmax <= abs ( a(imax,imax) ) ) then
        kstep = 1
        swap = .true.
      else if ( alpha * colmax * ( colmax / rowmax ) <= absakk ) then
        kstep = 1
        swap = .false.
      else
        kstep = 2
        swap = ( imax /= k-1 )
      end if

    end if
!
!  Column K is zero.
!  Set INFO and iterate the loop.
!
    if ( max ( absakk, colmax ) == 0.0E+00 ) then

      kpvt(k) = k
      info = k
!
!  1 x 1 pivot block.
!
!  Perform an interchange.
!
    else if ( kstep /= 2 ) then

      if ( swap ) then

        call sswap ( imax, a(1,imax), 1, a(1,k), 1 )

        do jj = imax, k
          j = k + imax - jj
          t = a(j,k)
          a(j,k) = a(imax,j)
          a(imax,j) = t
        end do

      end if
!
!  Perform the elimination.
!
      do jj = 1, k-1
        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
      end do
!
!  Set the pivot array.
!
      if ( swap ) then
        kpvt(k) = imax
      else
        kpvt(k) = k
      end if
!
!  2 x 2 pivot block.
!
!  Perform an interchange.
!
    else

      if ( swap ) then

        call sswap ( imax, a(1,imax), 1, a(1,k-1), 1 )

        do jj = imax, k-1
          j = k-1 + imax - jj
          t = a(j,k-1)
          a(j,k-1) = a(imax,j)
          a(imax,j) = t
        end do

        t = a(k-1,k)
        a(k-1,k) = a(imax,k)
        a(imax,k) = t

      end if
!
!  Perform the elimination.
!
      if ( k-2 /= 0 ) then

        ak = a(k,k) / a(k-1,k)
        akm1 = a(k-1,k-1) / a(k-1,k)
        denom = 1.0E+00 - ak * akm1

        do jj = 1, k-2

          j = k-1 - 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

        end do

      end if
!
!  Set the pivot array.
!
      if ( swap ) then
        kpvt(k) = -imax
      else
        kpvt(k) = 1 - k
      end if

      kpvt(k-1) = kpvt(k)

    end if

    k = k - kstep

  end do

  return
end
subroutine sswap ( n, x, incx, y, incy )

!*****************************************************************************80
!
!! SSWAP interchanges two real vectors.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Fortran90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vectors.
!
!    Input/output, real X(*), one of the vectors to swap.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input/output, real Y(*), one of the vectors to swap.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
  implicit none

  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer m
  integer n
  real temp
  real x(*)
  real y(*)

  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    m = mod ( n, 3 )

    do i = 1, m
      temp = x(i)
      x(i) = y(i)
      y(i) = temp
    end do

    do i = m+1, n, 3

      temp = x(i)
      x(i) = y(i)
      y(i) = temp

      temp = x(i+1)
      x(i+1) = y(i+1)
      y(i+1) = temp

      temp = x(i+2)
      x(i+2) = y(i+2)
      y(i+2) = temp

    end do

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      temp = x(ix)
      x(ix) = y(iy)
      y(iy) = temp
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
subroutine stat1 ( y, n, ymed, ymin, ymax, ymidrg, yrange, ncells, &
  ylb, yub, ydistr )

!*****************************************************************************80
!
!! STAT1 computes statistics for a sorted vector.
!
!  Discussion:
!
!    this subroutine is based on a modification of the statis
!    code used in omnitab, version 5 (6/16/72), writted by
!    sally peavy.  the original adaptation to starpac was made
!    by janet donaldson.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     ylb,ymax,ymed,ymidrg,ymin,yrange,yub
  integer &
     n,ncells
!
!  array arguments
  real &
     y(n),ydistr(ncells)
!
!
  real &
     dely,yt
  integer &
     i,ic,ic1,l,m,m1
!
!     variable definitions (alphabetically)
!
!     real dely
!        the width of an interval one tenth the range of the
!        data in y.
!     integer i
!        a loop index.
!     integer ic
!        previous sign in runs calculation.
!     integer ic1
!        count in frequency distribution calculations.
!     integer l
!        a loop index.
!     integer m
!        a loop index.
!     integer m1
!        when n is even, m1 is m + 1, otherwise it is m.
!     integer n
!        input parameter.  the length of y and wt.
!     integer ncells
!        the number of cells in the frequency distribution.
!     real y(n)
!        input parameter.  a set of n data points, sorted
!        into ascending order.
!     real ydistr(ncells)
!        output parameter.  the numbers of y values with
!        positive weights in each of ncells equal length intervals
!        that divide the range of y values.
!     real ylb
!        the lower bound for the frequency distribution.
!        if ylb = yub, the minimum observation will be used.
!     real ymax
!        output parameter.  the maximum of the observations y having
!        positive weight.
!     real ymed
!        output parameter.  the median of the observations y.
!     real ymidrg
!        output parameter.  the midrange of the observations y.
!     real ymin
!        output parameter.  the minimum of the observations y having
!        positive weight.
!     real yrange
!        the range of the observations y.
!     real yt
!        the maximum value in each interval in the frequency
!        distributions calculations.
!     real yub
!        the upper bound for the frequency distribution.
!        if ylb = yub, the maximum observation will be used.
!
!  calculate the median, midrange, range, and extrema.
!
  m = (n+1)/2
  m1 = m
  if (mod(n,2) == 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)
!
!  compute frequency distribution.
!
  if (ncells <= 0) return
  ic1 = 0

  if (ncells == 1) then
    ydistr(ncells) = real ( n - ic1 )
    return
  end if

  dely = yrange
  yt = ymin

  if ( ylb < yub ) then
     dely = yub - ylb
     yt = ylb
  end if

  dely = dely / real ( ncells )
  yt = yt + dely
  l = 0

  do i = 2, ncells

     ic = 0

     do

       l = l + 1

       if ( l > n ) then
         exit
       end if

       if (y(l) > yt) then
         exit
       end if

       ic = ic + 1
       ic1 = ic1 + 1

     end do

     ydistr(i-1) = real ( ic )
     l = l - 1
     yt = yt + dely

  end do

  ydistr(ncells) = real ( n - ic1 )

  return
end
subroutine stat1w ( y, wt, n, ymed, ymin, ymax, ymidrg, yrange, &
     ncells, ylb, yub, ydistr, nnzw )

!*****************************************************************************80
!
!! STAT1W computes statistics for a sorted vector with weights.
!
!  Discussion:
!
!    this subroutine is based on a modification of the statis
!    code used in omnitab, version 5 (6/16/72), writted by
!    sally peavy.  the original adaptation to starpac was made
!    by janet donaldson.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     ylb,ymax,ymed,ymidrg,ymin,yrange,yub
  integer &
     n,ncells,nnzw
!
!  array arguments
  real &
     wt(n),y(n),ydistr(ncells)
!
!
  real &
     dely,yt
  integer &
     i,ic,ic1,kk,l,m,m1,max,maxy,miny,n2
!
!     variable definitions (alphabetically)
!
!     real dely
!        the width of an interval one tenth the range of the
!        data in y.
!     integer i
!        a loop index.
!     integer ic
!        previous sign in runs calculation.
!     integer ic1
!        count in frequency distribution calculations.
!     integer kk
!        a backwards, boulder, colorado loop index.
!     integer l
!        a loop index.
!     integer m
!        a loop index.
!     integer max
!        index of a maximum element.
!     integer maxy
!        last element of y, the largest one.
!     integer miny
!        first element of y, the least one.
!     integer m1
!        ...
!     integer n
!        input parameter.  the length of y and wt.
!     integer ncells
!        the number of cells in the frequency distribution.
!     integer nnzw
!        input parameter.  the number of positive elements in wt.
!     integer n2
!        (nnzw + 1)/2
!     real wt(n)
!        input parameter.  the vector of weights for the
!        y observations.
!     real y(n)
!        input parameter.  a set of n data points, sorted
!        into ascending order.
!     real ydistr(ncells)
!        output parameter.  the numbers of y values with
!        positive weights in each of ten equal length intervals.
!        that divide the range of y values.
!     real ylb
!        the lower bound for the frequency distribution.
!        if ylb = yub, the minimum observation will be used.
!     real ymax
!        output parameter.  the maximum of the observations y having
!        positive weight.
!     real ymed
!        output parameter.  the median of the observations y.
!     real ymidrg
!        output parameter.  the midrange of the observations y.
!     real ymin
!        output parameter.  the minimum of the observations y having
!        positive weight.
!     real yrange
!        output parameter.  the range of the observations y.
!     real yt
!        the maximum value in each interval in the frequency
!        distributions calculations.
!     real yub
!        the upper bound for the frequency distribution.
!        if ylb = yub, the maximum observation will be used.
!
!     calculate the median.
!
  n2 = (nnzw+1)/2
  m = 1

  do i=1,n

    if ( i > n2 ) then
      exit
    end if

    m = i

    if ( wt(m) <= 0.0e0 ) then
      n2 = n2 + 1
    end if

  end do

  m1 = m

  if (mod(nnzw,2) /= 0) go to 40

  do m1=m,n
     if (wt(m1) > 0.0e0) go to 40
  end do

   40 ymed = (y(i)+y(m1))/2.0e0
!
!  calculate the midrange, range, minimum, and maximum.
!
  max = n - nnzw + 1

  do i=1,max
    miny = i
    if (wt(miny) > 0.0e0) then
      exit
    end if
  end do

  do i=1,max
    kk = n + 1 - i
    maxy = kk
    if (wt(maxy) > 0.0e0) then
      exit
    end if
  end do

  ymidrg = (y(miny)+y(maxy))/2.0e0
  yrange = y(maxy) - y(miny)
  ymin = y(miny)
  ymax = y(maxy)
!
!  compute frequency distribution
!
  dely = yrange
  yt = ymin

  if ( ylb < yub ) then
     dely = yub - ylb
     yt = ylb
  end if

  dely = dely / real ( ncells )
  yt = yt + dely
  l = 0
  ic1 = 0

  do i=2,ncells

     ic = 0

     do

       l = l + 1

       if (l > n) then
         exit
       end if

       if (wt(l) <= 0.0e0) then
         cycle
       end if

       if (y(l) > yt) then
         exit
       end if

       ic = ic + 1
       ic1 = ic1 + 1

     end do

     ydistr(i-1) = real ( ic )
     l = l - 1
     yt = yt + dely

  end do

  ydistr(ncells) = real ( nnzw - ic1 )

  return
end
subroutine stat2 ( y, n, sts, sumda, sumdi, sumd2, sumd3, sumd4 )

!*****************************************************************************80
!
!! STAT2 computes statistics that do not require sorted data.
!
!  Discussion:
!
!    this subroutine computes for a vector y the statistics that do
!    not require sorting of the vector, that is, those not computed
!    by stat1.  no weights are used.
!
!    this subroutine is based on a modification of the statis
!    code used in omnitab, version 5 (6/16/72), written by
!    sally peavy.  the original adaptation to starpac was
!    done by janet donaldson.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sumd2,sumd3,sumd4,sumda,sumdi
  integer &
     n
!
!  array arguments
  real &
     sts(53),y(n)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     dif,t,ta,tk1,tk2
  integer &
     i,ic,ici,idruns,iminus,iplus,irun
!
!  external functions
  real &
     cdff,ppfchs,ppft
  external cdff,ppfchs,ppft
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real dif
!        the sum of the differences between succeeding elements
!        in y.
!     integer i
!        a loop index.
!     integer ic
!        previous sign in runs calculation.
!     integer ici
!        current sign in runs calculation.
!     integer idruns
!        the number of runs.
!     integer ierr
!        an error flag set in common errchk.
!     integer iminus, iplus
!        counts of signs of deviations.
!     integer irun
!        the number of runs up and down.
!     integer n
!        input parameter.  the length of y and wt.
!     real sts(53)
!        output parameter.  the vector of 53 statistics computed.
!        row statistic                    row statistic
!         1  length of vector             tests for nonrandomness
!         2  number of nonzero weights    23  number of runs up and down
!        measures of location             24  expected number of runs
!         3  unweighted mean              25  s.d. of number of runs
!         4  weighted mean                26  mean sqr. successive diff.
!         5  median                       27  mean sqr. succ. diff./var.
!         6  mid-range                    deviations from wtd mean
!         7  25 p.c. unwtd. trimmed mean  28  number of + signs
!         8  25 p.c. wtd. trimmed mean    29  number of - signs
!        measures of dispersion           30  number of runs
!         9  standard deviation (s.d.)    31  expected number of runs
!        10  s.d. of mean                 32  s.d. of runs
!        11  range                        33  diff./s.d. of runs
!        12  mean variation               other statistics
!        13  variance (var.)              34  minimum
!        14  coefficient of variation     35  maximum
!        confidence intervals             36  beta 1
!        15  lower confidence limit, mean 37  beta 2
!        16  upper confidence limit, mean 38  wtd. sum of values
!        17  lower confidence limit, s.d. 39  wtd. sum of squares
!        18  upper confidence limit, s.d. 40  wtd. sum of sqrd. devs.
!        linear trend statistics          41  students t
!        19  slope                        42  wtd. sum of abs. values
!        20  s.d. of slope                43  wtd. avg. abs. values
!        21  slope/s.d. of slope = t      44-53 freq. distribution
!        22  prob ( x > abs(obs. t))
!     real sumda
!        input parameter.  the sum of the absolute values of the
!        differences diff.
!     real sumdi
!        input parameter.  the sum of the products of i and the
!        ith difference diff.
!     real sumd2
!        input parameter.  the sum of the squares of the
!        differences diff.
!     real sumd3
!        input parameter.  the sum of the cubes of the
!        differences diff.
!     real sumd4
!        input parameter.  the sum of the hypercubes of the
!        differences diff.
!     real t
!        a residual (y(i) - meany)
!     real ta
!        a temporary variable in the runs calculation.
!     real tk1, tk2
!        chi-squared values.
!     real y(n)
!        input parameter.  a set of n data points, sorted
!        into ascending order.
!
!  begin storage of statistics.
!
  sts(1) = real ( 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)
!
!  compute residuals and standard deviations.
!
  ici = 0
  iplus = 0
  iminus = 0
  idruns = 0
  ic = 0

  do i=1,n

     t = y(i) - sts(4)

     if ( t < 0.0e0 ) then
       iminus = iminus + 1
       ici = -1
     else
       iplus = iplus + 1
       ici = +1
     end if

     if (ic /= ici) then
       ic = ici
       idruns = idruns + 1
    end if

  end do

  sts(28) = real ( iplus )
  sts(29) = real ( 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) = real ( idruns )
  sts(33) = 0.0e0
  if (sts(32) /= 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) /= 0.0e0) &
     sts(14) = 100.0e0*abs(sts(9)/sts(4))
  if (sts(4) == 0.0e0) sts(14) = 0.0e0
  sts(36) = 0.0e0
  if (sumd2 > 0.0e0) &
     sts(36) = (sumd3/sts(1))**2/((sumd2/sts(1))**3)
  sts(37) = 0.0e0
  if (sumd2 > 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) <= 0.0e0) sts(20) = 0.0e0
  sts(20) = sqrt(sts(20))
  if (sts(20) == 0.0e0) sts(21) = 0.0e0
  if (sts(20) > 0.0e0) sts(21) = sts(19)/sts(20)

  sts(22) = 1.0e0 - cdff(sts(21)*sts(21), 1.0e0, sts(1)-2.0e0)
!
!  compute number of runs in the data.
!
  dif = 0.0e0
  irun = 1
  ta = 0.0e0

  do i=1,n

    if ( i  >=  n ) then
      exit
    end if

    ta = y(i+1) - y(i)

    if ( ta /= 0.0e0 ) then
      exit
    end if

  end do

  do i=1,n

    if ( i == n ) then
      cycle
    end if

    t = y(i+1) - y(i)
    dif = dif + t*t
    if (ta*t < 0.0e0) then
      ta = t
      irun = irun + 1
    end if

  end do

  sts(23) = real ( irun )
  sts(26) = dif/(sts(1)-1.0e0)
  sts(27) = 0.0e0
  if (sts(13) /= 0.0e0) &
     sts(27) = sts(26)/sts(13)
  sts(41) = 0.0e0
  if (sts(9) /= 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
subroutine stat2w ( y, wt, n, nnzw, sts, sumda, sumdi, sumwd2, &
     sumd2, sumd3, sumd4, sumw )

!*****************************************************************************80
!
!! STAT2W computes statistics on an unsorted, weighted vector.
!
!  Discussion:
!
!    this subroutine computes for a vector y the statistics that do
!    not require sorting of the vector, that is, those not computed
!    by stat1w.  weights are used in the calculations.
!
!    this subroutine is based on a modification of the statis
!    code used in omnitab, version 5 (6/16/72), written by
!    sally peavy.  the original adaptation to starpac was
!    done by janet donaldson.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sumd2,sumd3,sumd4,sumda,sumdi,sumw,sumwd2
  integer &
     n,nnzw
!
!  array arguments
  real &
     sts(53),wt(n),y(n)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     dif,t,ta,tk1,tk2
  integer &
     i,ic,ici,icount,idruns,iminus,iplus,irun,j
!
!  external functions
  real &
     cdff,ppfchs,ppft
  external cdff,ppfchs,ppft
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real dif
!        the sum of the differences between succeeding elements
!        in y.
!     integer i
!        a loop index.
!     integer ic
!        previous sign in runs calculation.
!     integer ici
!        current sign in runs calculation.
!     integer icount
!        used in runs calculations.
!     integer idruns
!        the number of runs.
!     integer ierr
!        an error flag set in common errchk.
!     integer iminus, iplus
!        counts of signs of deviations.
!     integer irun
!        the number of runs up and down.
!     integer j
!        a loop index.
!     integer n
!        input parameter.  the length of y and wt.
!     integer nnzw
!        input parameter.  the number of positive elements in wt.
!     real sts(53)
!        output parameter.  the vector of 53 statistics computed.
!     row statistic                    row statistic
!         1  length of vector             tests for nonrandomness
!         2  number of nonzero weights    23  number of runs up and down
!        measures of location             24  expected number of runs
!         3  unweighted mean              25  s.d. of number of runs
!         4  weighted mean                26  mean sqr. successive diff.
!         5  median                       27  mean sqr. succ. diff./var.
!         6  mid-range                    deviations from wtd mean
!         7  25 p.c. unwtd. trimmed mean  28  number of + signs
!         8  25 p.c. wtd. trimmed mean    29  number of - signs
!        measures of dispersion           30  number of runs
!         9  standard deviation (s.d.)    31  expected number of runs
!        10  s.d. of mean                 32  s.d. of runs
!        11  range                        33  diff./s.d. of runs
!        12  mean variation               other statistics
!        13  variance (var.)              34  minimum
!        14  coefficient of variation     35  maximum
!        confidence intervals             36  beta 1
!        15  lower confidence limit, mean 37  beta 2
!        16  upper confidence limit, mean 38  wtd. sum of values
!        17  lower confidence limit, s.d. 39  wtd. sum of squares
!        18  upper confidence limit, s.d. 40  wtd. sum of sqrd. devs.
!        linear trend statistics          41  students t
!        19  slope                        42  wtd. sum of abs. values
!        20  s.d. of slope                43  wtd. avg. abs. values
!        21  slope/s.d. of slope = t      44-53 freq. distribution
!        22  prob ( x > abs(obs. t))
!     real sumda
!        input parameter.  the sum of the absolute values of the
!        differences diff.
!     real sumdi
!        input parameter.  the sum of the products of i and the
!        ith difference diff.
!     real sumd2
!        input parameter.  the sum of the squares of the
!        differences diff.
!     real sumd3
!        input parameter.  the sum of the cubes of the
!        differences diff.
!     real sumd4
!        input parameter.  the sum of the hypercubes of the
!        differences diff.
!     real sumw
!        input parameter.  the sum of the weights vector wt.
!     real sumwd2
!        input parameter.  the weighted sum of the squared
!        differences diff.
!     real t
!        a residual (y(i) - meany)
!     real ta
!        a temporary variable in the runs calculation.
!     real tk1, tk2
!        chi-squared values.
!     real wt(n)
!        input parameter.  the vector of weights for the
!        y observations.
!     real y(n)
!        input parameter.  a set of n data points, sorted
!        into ascending order.
!
  sts(1) = real ( n )
  sts(2) = real ( 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
!
!  compute residuals and standard deviations.
!
  ici = 0
  iplus = 0
  iminus = 0
  idruns = 0
  ic = 0

  do i=1,n

    if (wt(i) <= 0.0e0) then
      cycle
    end if

    t = y(i) - sts(4)

    if ( t < 0.0e0 ) then
      iminus = iminus + 1
      ici = -1
    else
      iplus = iplus + 1
      ici = 1
    end if

    if ( ic /= ici ) then
      ic = ici
      idruns = idruns + 1
    end if

  end do

  sts(28) = real ( iplus )
  sts(29) = real ( 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) = real ( idruns )
  sts(33) = 0.0e0
  if (sts(32) /= 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) /= 0.0e0) &
     sts(14) = 100.0e0*abs(sts(9)/sts(4))
  if (sts(4) == 0.0e0) sts(14) = 0.0e0
  sts(36) = 0.0e0
  if (sumd2 /= 0.0e0) &
     sts(36) = (sumd3/sts(2))**2/((sumd2/sts(2))**3)
  sts(37) = 0.0e0
  if (sumd2 /= 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) <= 0.0e0) sts(20) = 0.0e0
  sts(20) = sqrt(sts(20))
  if (sts(20) == 0.0e0) sts(21) = 0.0e0
  if (sts(20) > 0.0e0) sts(21) = sts(19)/sts(20)

  sts(22) = 1.0e0 - cdff(sts(21)*sts(21), 1.0e0, sts(2)-2.0e0)
!
!  compute number of runs in the data.
!
  dif = 0.0e0
  irun = 1
  ta = 0.0e0

  do i=1,n

    if (i >= n) then
      exit
    end if

    if ( wt(i) <= 0.0e0 ) then
      cycle
    end if

    j = i

   40    continue

    j = j + 1
    if (j >= n) go to 60
    if (wt(j) <= 0.0e0) go to 40

    ta = y(j) - y(i)

    if (ta /= 0.0e0) then
      exit
    end if

  end do

   60 icount = 0

  do i=1,n

    if (wt(i) <= 0.0e0) then
      cycle
    end if

    icount = icount + 1

    if (icount >= nnzw) then
      cycle
    end if

    j = i
    do
      j = j + 1
      if ( 0.0E+00 < wt(j) ) then
        exit
      end if
    end do

    t = y(j) - y(i)
    dif = dif + t*t

    if ( ta * t < 0.0e0 ) then
      ta = t
      irun = irun + 1
    end if

  end do

  sts(23) = real ( irun )
  sts(26) = dif/(sts(2)-1.0e0)
  sts(27) = 0.0e0
  if (sts(13) /= 0.0e0) then
     sts(27) = sts(26)/sts(13)
  end if
  sts(41) = 0.0e0
  if (sts(9) /= 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
subroutine stater ( nmsub, wt, n, ldstak, wts, nnzw, stack, ierr )

!*****************************************************************************80
!
!! STATER does error checking for the STAT family of routines.
!
!  Discussion:
!
!    this subroutine checks input parameters to the user
!    callable members of the stat family of routines
!    for errors and reports any that it finds, besides
!    returning a flag indicating that errors have been
!    found.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ierr,ldstak,n,nnzw
  logical &
     stack,wts
!
!  array arguments
  real &
     wt(*)
  character &
     nmsub(6)*1
!
!
  integer &
     ldsmin,nzw
  logical &
     head,ier1,ier2,ier3
!
!  local arrays
  character &
     llds(8)*1,ln(8)*1,lthree(8)*1,lwt(8)*1
!
!  external subroutines
  external eisge,ervwt,ldscmp
!
!     variable definitions (alphabetically)
!
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        output parameter.  a flag indicating whether or
!        not an error has been found.  0 = ok, 1 = error.
!     logical ier1
!        true if n < 3
!     logical ier2
!        true if ldstak < (n + 13)/2.0e0
!     logical ier3
!        true if some wt < 0.0e0 or nnzw < 3
!     integer ldsmin
!        minimum length of framework area in double
!        precision elements.
!     integer ldstak
!        input parameter.  the number of locations provided in
!        the framework area.
!     character*1 llds(8), ln(8), lthree(8), lwt(8)
!        the array(s) containing the name(s) fo the varialbe(s) checked
!        for errors
!     integer n
!        input parameter.  the number of elements in y and wt.
!     character*1 nmsub(6)
!        the name of the calling subroutine
!     integer nnzw
!        output parameter.  if wts, then set equal to the
!        number of values in wt which are positive.  else,
!        undefined.
!     integer nzw
!        the number of zero weights.
!     logical stack
!        a flag indicating whether this routine uses the stack (true)
!        or not (false).
!     real wt(n)
!        input parameter.  the vector of weights corresponding
!        to the vector y.
!     logical wts
!        input parameter.  a flag indicating whether or not
!        there is really a vector wt (true), or only a dummy parameter
!        (false).
!
!     initialize name vectors
!
  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', ' ', ' ', ' ', ' ', ' ', ' '/
!
!  initialize error flags
!
  ier1 = .false.
  ier2 = .false.
  ier3 = .false.

  ierr = 0

  head = .true.
!
!  Check to see that there are at least three data points.
!
  call eisge(nmsub, ln, n, 3, 2, head, ier1, lthree)
!
!  Check to see that an amount of work area equal
!  in length to the requirements of the permutation
!  vector will be available.
!
  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
!
!  If there are weights, check that at least three data items have
!  nonzero weights.
!
  nnzw = n
  if (wts) then
     call ervwt(nmsub, lwt, wt, n, 3, head, nnzw, nzw, 1, ier3, lthree)
  end if

  if (ier1 .or. ier2 .or. ier3) ierr = 1

  return
end
subroutine stat ( y, n, ldstak )

!*****************************************************************************80
!
!! STAT computes 53 statistics for an unweighted vector.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ldstak,n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,sumd2,sumd3,sumd4,sumda,sumdi,sumt1
  integer &
     idp,iint,lsort,mid,nall0,nnzw
  logical &
     stack,wts
!
!  local arrays
  real &
     sts(53),wt(1)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external geni,srtir,srtri,stat1,stat2,stater,stkclr,stkset, &
     sumbs,sumds,sumid,sumot,sumss,sumts
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real alpha
!        the percentage to be trimmed off each end of y for the
!        trimmed means calculations.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idp
!        the code value for double precision for framework.
!     integer ierr
!        the code indicating whether or not an error has
!        been discovered.  0 means no error, not 0 means
!        some error exists.
!     integer iint
!        the code value for integer for framework
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        input parameter.  the number of double precision
!        elements dimensioned for dstak in the user program.
!     integer lsort
!        the starting location in istak of the permutation
!        vector.
!     integer mid
!        the index of the (an) element of y closest to zero, when
!        y has been sorted.
!     integer n
!        input parameter.  the length of y.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nnzw
!        number of nonzero weights.
!     logical stack
!        a flag indicating whether this routine uses the stack (true)
!        or not (false).
!     real sts(53)
!        the vector of the 53 statistics computed.
!     real sumda
!        the sum of the absolute differences from the mean.
!     real sumdi
!        the sum of the products of the indices and the differences.
!     real sumd2
!        the sum of the squares of the differences.
!     real sumd3
!        the sum of the cubes of the differences.
!     real sumd4
!        the sum of the 4th powers of the differences.
!     real sumt1
!        the sum of the alpha trimmed array y.
!     real wt(1)
!        the dummy weights vector.
!     logical wts
!        a flag indicating whether there are weights (true)
!        or not (false).
!     real y(n)
!        input parameter.  the vector of data points on which
!        the statistics are computed.  y is sorted, but restored
!        to its original order afterwards.
!
!     initialize name vectors
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       's',      't',      'a',      't',      ' ',      ' '/

  data alpha /0.25e0/
  data idp /4/
  data iint /2/
  data wts /.false./
  data stack /.true./
!
!  check for errors in the input parameters
!
  call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr)
!
!  print error message.
!
  if (ierr /= 0) then
     write ( *,1000)
     return
  end if
!
!  set up framework area.
!
  call stkset (ldstak, idp)
  nall0 = stkst(1)
!
!  set up lsort, the permutation vector.
!
  lsort = stkget(n,iint)
  call geni(istak(lsort), n, 1, 1)
!
!  sort the vector y.
!
  call srtir(istak(lsort), n, y)
!
!  compute the statistics which use a sorted array.
!
  call stat1(y, n, sts(5), sts(34), sts(35), sts(6), &
     sts(11), 10, 0.0e0, 0.0e0, sts(44))
!
!  calculate sums of the sorted array.
!
  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)
!
!  restore the vector y to its original order.
!
  call srtri(y, n, istak(lsort))
!
!  compute rest of statistics.
!
  call sumid(y, n, sts(3), sumdi)
  call stat2(y, n, sts, sumda, sumdi, sumd2, sumd3, sumd4)
  call sumot(sts, n, n, wts)
!
!  return the vector lsort.
!
  call stkclr(nall0)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call stat (y, n, ldstak)')
end
subroutine stats ( y, n, ldstak, sts, nprt )

!*****************************************************************************80
!
!! STATS computes 53 different statistics for an unweighted vector.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ldstak,n,nprt
!
!  array arguments
  real &
     sts(53),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,sumd2,sumd3,sumd4,sumda,sumdi,sumt1
  integer &
     idp,iint,lsort,mid,nall0,nnzw
  logical &
     stack,wts
!
!  local arrays
  real &
     wt(1)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external geni,srtir,srtri,stat1,stat2,stater,stkclr,stkset, &
     sumbs,sumds,sumid,sumot,sumss,sumts
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real alpha
!        the percentage to trim from each end in the trimmed
!        means.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idp
!        framework code value for double precision numbers.
!     integer ierr
!        the code indicating whether or not an error has
!        been discovered.  0 means no error, not 0 means
!        some error exists.
!     integer iint
!        the code value for integer for framework.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        input parameter.  the number of double precision
!        elements dimensioned for dstak in the user program.
!     integer lsort
!        the starting location in istak of the permutation
!        vector.
!     integer mid
!        in the sorted array y, a point equal to or the point
!        closest to, zero.
!     integer n
!        input parameter.  the length of y.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        input parameter.  flag to control output.
!        0 means no output.  other values mean output.
!     integer nnzw
!        number of nonzero weights.
!     logical stack
!        a flag indicating whether this routine uses the stack (true)
!        or not (false).
!     real sts(53)
!        output parameter.  the vector of the 53 statistics computed.
!     real sumda
!        the sum of the absolute values of the differences from
!        the mean.
!     real sumdi
!        the sum of the products of the index and differences.
!     real sumd2
!        the sum of the square of the differences.
!     real sumd3
!        the sum of the cube of the differences.
!     real sumd4
!        the sum of the 4th powers of the differences.
!     real sumt1
!        the trimmed unweighted simple sum of elements in y.
!     real wt(1)
!        the dummy weights vector.
!     logical wts
!        a flag indicating whether there are weights (true)
!        or not (false).
!     real y(n)
!        input parameter.  the vector of data points on which
!        the statistics are computed.  y is sorted, but restored
!        to its original order afterwards.
!
!     initialize name vectors
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       's',      't',      'a',      't',      's',      ' '/

  data alpha /0.25e0/
  data idp /4/
  data iint /2/
  data wts /.false./
  data stack /.true./
!
!  check for errors in the input parameters.
!
  call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr)
  if (ierr /= 0) then
!
!  set up the output unit number.
!
     write ( *,1000)
     return
  end if
!
!  set up framework area
!
  call stkset (ldstak, idp)
  nall0 = stkst(1)
!
!  set up lsort, the permutation vector.
!
  lsort = stkget(n,iint)
  call geni(istak(lsort), n, 1, 1)
!
!  sort the vector y.
!
  call srtir(istak(lsort), n, y)
!
!  compute the statistics which use a sorted array.
!
  call stat1(y, n, sts(5), sts(34), sts(35), sts(6), &
     sts(11), 10, 0.0e0, 0.0e0, sts(44))
!
!  calculate sums of the sorted array.
!
  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)
!
!  restore the vector y to its original order.
!
  call srtri(y, n, istak(lsort))
!
!  compute rest of statistics.
!
  call sumid(y, n, sts(3), sumdi)
  call stat2(y, n, sts, sumda, sumdi, sumd2, sumd3, sumd4)
  if (nprt /= 0) call sumot(sts, n, n, wts)
!
!  return the vector lsort.
!
  call stkclr(nall0)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call stats (y, n, ldstak, sts, nprt)')
end
subroutine statw ( y, wt, n, ldstak )

!*****************************************************************************80
!
!! STATW computes 53 statistics for a weighted vector.
!
!  Discussion:
!
!    this subroutine computes 53 different statistics for a
!    vector y, with weights specified.  one page of automatic
!    printout is produced.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ldstak,n
!
!  array arguments
  real &
     wt(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,sum1,sumd2,sumd3,sumd4,sumda,sumdi,sumt1,sumw,sumwd2, &
     sumwt1
  integer &
     idp,iint,lsort,mid,nall0,nnzw
  logical &
     stack,wts
!
!  local arrays
  real &
     sts(53)
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external geni,srtirr,srtrri,stat1w,stat2w,stater,stkclr, &
     stkset,sumbs,sumidw,sumot,sumwds,sumwss,sumwts
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real alpha
!        the percentage of points to be trimmed from either end of
!        y in calculating the trimmed means.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idp
!        framework code value for double precision numbers.
!     integer ierr
!        the code indicating whether or not an error has
!        been discovered.  0 means no error, not 0 means
!        some error exists.
!     integer iint
!        the code value for integer for framework.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        input parameter.  the number of double precision
!        elements dimensioned for dstak in the user program.
!     integer lsort
!        the starting location in istak of the permutation
!        vector.
!     integer mid
!        the index of a zero element in the sorted y, or of the
!        element closest to zero.
!     integer n
!        input parameter.  the length of y.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nnzw
!        number of nonzero weights.
!     logical stack
!        a flag indicating whether this routine uses the stack (true)
!        or not (false).
!     real sts(53)
!        the vector of the 53 statistics computed.
!     real sumda
!        the sum of the absolute differences from the mean.
!     real sumdi
!        the sum of the products of the indices and the
!        differences.
!     real sumd2
!        the sum of the squares of the differences.
!     real sumd3
!        the sum of the cubes of the differences.
!     real sumd4
!        the sum of the 4th powers of the differences.
!     real sumt1
!        the sum of the alpha trimmed array y.
!     real sumw
!        the sum of the weights vector wt.
!     real sumwd2
!        the weighted sum of the squares of the differences.
!     real sumwt1
!        the weighted sum of the alpha trimmed array.
!     real sum1
!        the unweighted sum of the elements of y.
!     real wt(n)
!        input parameter.  the weights vector.
!     logical wts
!        a flag indicating whether there are weights (true)
!        or not (false).
!     real y(n)
!        input parameter.  the vector of data points on which
!        the statistics are computed.  y is sorted, but restored
!        to its original order afterwards.
!
!     initialize name vectors
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       's',      't',      'a',      't',      'w',      ' '/

  data alpha /0.25e0/
  data idp /4/
  data iint /2/
  data wts /.true./
  data stack /.true./
!
!  check for errors in the input parameters.
!
  call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr)
  if (ierr /= 0) then
!
!  print error message.
!
     write ( *,1000)
     return
  end if
!
!  set up framework area.
!
  call stkset (ldstak, idp)
  nall0 = stkst(1)
!
!  set up lsort, the permutation vector.
!
  lsort = stkget(n,iint)
  call geni(istak(lsort), n, 1, 1)
!
!  sort the vector y.
!
  call srtirr(istak(lsort), wt, n, y)
!
!  compute the statistics which use a sorted array.
!
  call stat1w(y, wt, n, sts(5), sts(34), sts(35), sts(6), &
     sts(11), 10, 0.0e0, 0.0e0, sts(44), nnzw)
!
!  computed various sums in the sorted array y.
!
  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)
!
!  restore the vector y to its original order.
!
  call srtrri(y, wt, n, istak(lsort))
!
!  compute rest of statistics.
!
  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)
!
!  return the vector lsort.
!
  call stkclr(nall0)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call statw (y, wt, n, ldstak)')
end
subroutine statws ( y, wt, n, ldstak, sts, nprt )

!*****************************************************************************80
!
!! STATWS computes 53 statistics for a weighted vector.
!
!  Discussion:
!
!    this subroutine computes 53 different statistics for a vector
!    y, with weights specified.  one page of automatic
!    printout is produced.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    Janet Donaldson, John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ldstak,n,nprt
!
!  array arguments
  real &
     sts(53),wt(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,sum1,sumd2,sumd3,sumd4,sumda,sumdi,sumt1,sumw,sumwd2, &
     sumwt1
  integer &
     idp,iint,lsort,mid,nall0,nnzw
  logical &
     stack,wts
!
!  local arrays
  integer &
     istak(12)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external geni,srtirr,srtrri,stat1w,stat2w,stater,stkclr, &
     stkset,sumbs,sumidw,sumot,sumwds,sumwss,sumwts
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real alpha
!        the percentage to be trimmed from each end of the
!        sorted array y.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer idp
!        framework code value for double precision numbers.
!     integer ierr
!        the code indicating whether or not an error has
!        been discovered.  0 means no error, not 0 means
!        some error exists.
!     integer iint
!        the code value for integer for framework.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer ldstak
!        input parameter.  the number of double precision
!        elements dimensioned for dstak in the user program.
!     integer lsort
!        the starting location in istak of the permutation vector.
!     integer mid
!        the index of a zero element in the sorted y, or of the
!        element closest to zero.
!     integer n
!        input parameter.  the length of y.
!     integer nall0
!        the number of allocations outstanding at the time this routine
!        was called.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        input parameter.  the code indicating whether printout
!        is desired.  0 means no printout, not 0 means printout.
!     integer nnzw
!        number of nonzero weights.
!     logical stack
!        a flag indicating whether this routine uses the stack (true)
!        or not (false).
!     real sts(53)
!        output parameter.  the vector of the 53 statistics computed.
!     real sumda
!        the sum of the absolute differences from the mean.
!     real sumdi
!        the sum of the products of the indices and the
!        differences.
!     real sumd2
!        the sum of the squares of the differences.
!     real sumd3
!        the sum of the cubes of the differences.
!     real sumd4
!        the sum of the 4th powers of the differences.
!     real sumt1
!        the sum of the alpha trimmed array y.
!     real sumw
!        the sum of the weights vector wt.
!     real sumwd2
!        the weighted sum of the squares of the differences.
!     real sumwt1
!        the weighted sum of the alpha trimmed array.
!     real sum1
!        the sum of the elements of x.  a dummy variable.
!     real wt(n)
!        input parameter.  the weights vector.
!     logical wts
!        a flag indicating whether there are weights (true)
!        or not (false).
!     real y(n)
!        input parameter.  the vector of data points on which
!        the statistics are computed.  y is sorted, but restored
!        to its original order afterwards.
!
!     initialize name vectors
!
  data  nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) &
     /       's',      't',      'a',      't',      'w',      's'/

  data alpha /0.25e0/
  data idp /4/
  data iint /2/
  data wts /.true./
  data stack /.true./
!
!  check for errors in the input parameters.
!
  call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr)

  if (ierr /= 0) then
     write ( *,1000)
     return
  end if
!
!  set up framework area.
!
  call stkset (ldstak, idp)
  nall0 = stkst(1)
!
!  set up lsort, the permutation vector.
!
  lsort = stkget(n,iint)
  call geni(istak(lsort), n, 1, 1)
!
!  sort the vector y carrying along the contents of the vector
!  istak(lsort).
!
  call srtirr(istak(lsort), wt, n, y)
!
!  compute the statistics which use a sorted array.
!
  call stat1w(y, wt, n, sts(5), sts(34), sts(35), sts(6), &
     sts(11), 10, 0.0e0, 0.0e0, sts(44), nnzw)
!
!  computed various sums in the sorted array y.
!
  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)
!
!  restore the vector y to its original order.
!
  call srtrri(y, wt, n, istak(lsort))
!
!  compute rest of statistics.
!
  call sumidw(y, wt, n, sts(4), sumdi)
  call stat2w(y, wt, n, nnzw, sts, sumda, sumdi, sumwd2, sumd2, &
     sumd3, sumd4, sumw)
  if (nprt /= 0) call sumot(sts, n, nnzw, wts)
!
!  return the vector lsort.
!
  call stkclr(nall0)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call statws (y, wt, n, ldstak, sts, nprt)')
end
subroutine stkclr ( nall0 )

!*****************************************************************************80
!
!! STKCLR clears the stack for framework area manipulation routines.
!
!  Discussion:
!
!    This routine is an addition to the framework area manipulation
!    routines.  it clears all allocations made since the first nall0.
!    it is intended for use during error or final exits from starpac
!    routines which make allocations, to release all allocations
!    made since the nall0 existing on entry to the starpac routine,
!    without knowing how many allocations must be released.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer nall0
!        input parameter.  the number of allocations to be preserved
!        when all later ones are released.
!     integer nalln
!        the total number of allocations existing before any are
!        released.
!
  implicit none

  integer nall0
  integer nalln
  integer stkst

  nalln = stkst ( 1 )

  call stkrel ( nalln - nall0 )

  return
end
function stkget ( nitems, itype )

!*****************************************************************************80
!
!! STKGET allocates space on an integer stack.
!
!  Discussion:
!
!    This routine allocates space out of the integer array ISTAK,
!    in common block CSTAK, for an array of length NITEMS and of type
!    determined by ITYPE as follows
!
!    1 - logical
!    2 - integer
!    3 - real
!    4 - double precision
!    5 - complex
!
!    on return, the array will occupy
!
!    stak(stkget), stak(stkget+1), ..., stak(stkget-nitems+1)
!
!  where stak is an array of type itype equivalenced to istak.
!
!  (for those wanting to make machine dependent modifications
!  to support other types, codes 6, 7, 8, 9, 10, 11 and 12 have
!  been reserved for 1/4 logical, 1/2 logical, 1/4 integer,
!  1/2 integer, quad precision, double complex and quad
!  complex, respectively.)
!
!  the use of the first five words is described below.
!
!    istak( 1) - lout,  the number of current allocations.
!    istak( 2) - lnow,  the current active length of the stack.
!    istak( 3) - lused, the maximum value of istak(2) achieved.
!    istak( 4) - lmax,  the maximum length the stack.
!    istak( 5) - lbook, the number of words used for bookeeping.
!
!  the next five words contain integers describing the amount
!  of storage allocated by the fortran system to the various
!  data types.  the unit of measurement is arbitrary and may
!  be words, bytes or bits or whatever is convenient.  the
!  values currently assumed correspond to an ans fortran
!  environment.  for some mini-computer systems the values may
!  have to be changed (see i0tk00).
!
!    istak( 6) - the number of units allocated to logical
!    istak( 7) - the number of units allocated to integer
!    istak( 8) - the number of units allocated to real
!    istak( 9) - the number of units allocated to double precision
!    istak(10) - the number of units allocated to complex
!
!     this function was adapted from the framework function istkgt
!
!  Modified:
!
!    28 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer i
!        the location of a pointer to the end of the previous allocation
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer isize(5)
!        the number of words in each of the various data types.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer itype
!        the type of array of length nitems to be allocated.
!     integer lbook
!        the number of words used for bookeeping.
!     integer lmax
!        the maximum length of the stack.
!     integer lnow
!        the current active length of the stack.
!     integer lout
!        the number of current allocations.
!     integer lused
!        the maximum value of istak(2) achieved.
!     integer nitems
!        the length of the array of itype to be allocated.
!
  implicit none

  double precision dstak(12)
  integer i
  integer ierr
  integer isize(5)
  integer istak(12)
  integer itype
  integer lbook
  integer lmax
  integer lnow
  integer lout
  integer lused
  integer nitems
  integer stkget

  common /cstak/dstak
  common /errchk/ierr
!
!  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) )

  stkget = ( lnow * isize(2) - 1 ) / isize(itype) + 2

  i = ( ( stkget - 1 + nitems ) * isize(itype) - 1 ) / isize(2) + 3
!
!  stack overflow is an unrecoverable error.
!
  if ( lmax < i ) then
    ierr = 1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'STKGET - Fatal error!'
    write ( *, '(a)' ) '  Stacksize exceeded.'
    stop
  end if
!
!  istak(i-1) contains the type for this allocation.
!  istak(i  ) contains a pointer to the end of the previous allocation.
!
  istak(i-1) = itype
  istak(i  ) = lnow
  lout = lout + 1
  lnow = i
  lused = max ( lused, lnow )

  return
end
subroutine stkrel ( number )

!*****************************************************************************80
!
!! STKREL deallocates the last allocations made in the stack.
!
!  Discussion:
!
!    error states -
!
!    1 - number < 0
!    2 - lnow, lused, lmax or lbook overwritten
!    3 - attempt to de-allocate non-existent allocation
!    4 - the pointer at istak(lnow) overwritten
!
!    this function was adapted from the framework function istkgt
!
!  Modified:
!
!    28 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer lbook
!        the number of words used for bookeeping.
!     integer lmax
!        the maximum length of the stack.
!     integer lnow
!        the current active length of the stack.
!     integer lout
!        the number of current allocations.
!     integer lused
!        the maximum value of istak(2) acheived.
!     integer number
!        the number of allocations to be freed from the stack.
!
  implicit none

  integer ierr
  integer number
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     in,lbook,lmax,lnow,lout,lused
!
!  local arrays
  integer &
     istak(12)
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  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)

  if ( lnow < lbook .or. lnow > lused .or. lused > lmax ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  in = number

  do

    if ( in == 0 ) then
      exit
    end if

    if ( lnow <= lbook ) then
      ierr = 1
      write ( *, 1010)
      return
    end if
!
!  check to make sure the back pointers are monotone.
!
    if (istak(lnow)<lbook.or.istak(lnow) >= lnow-1) then
      ierr = 1
      write ( *, 1020) lout
      return
    end if

    lout = lout-1
    lnow = istak(lnow)
    in = in-1

  end do

  return

 1000 format (///' ***** error *****'// &
     ' dstak bookkeeping elements have been overwritten.')
 1010 format (///' ***** error *****'// &
     ' attempt has been made to de-allocate a non-existent', &
     ' allocation in dstak.')
 1020 format (///' ***** error *****'// &
     ' the pointer for allocation number ', i3, ' has been', &
     ' overwritten.')

end
subroutine stkset ( nitems, itype )

!*****************************************************************************80
!
!! STKSET initializes the stack to NITMES of type ITYPE.
!
!  Discussion:
!
!    this function was adapted from the framework subroutine istkin
!
!  Modified:
!
!    28 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer isize(5)
!        the number of words in each of the various data types.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer itype
!        the type of array of length nitems to be allocated.
!     integer lbook
!        the number of words used for bookeeping.
!     integer lmax
!        the maximum length of the stack.
!     integer lnow
!        the current active length of the stack.
!     integer lout
!        the number of current allocations.
!     integer lused
!        the maximum value of istak(2) acheived.
!     integer nitems
!        the length of the array of itype to be allocated.
  implicit none

  integer itype
  integer nitems
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     lbook,lmax,lnow,lout,lused
!
!  local arrays
  integer &
     isize(5),istak(12)
!
!  common blocks
  common /cstak/dstak
!
!  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))
!
!  here to initialize
!
!  set data sizes appropriate for a standard conforming
!  fortran system using the fortran "storage unit" as the
!  measure of size.
!
!  logical
!
  isize(1) = 1
!
!  integer
!
  isize(2) = 1
!
!  real
!
  isize(3) = 1
!
!  double precision
!
  isize(4) = 2
!
!  complex
!
  isize(5) = 2

  lbook = 10
  lnow  = lbook
  lused = lbook
  lmax  = max ( ( nitems * isize(itype) ) / isize(2), 12 )
  lout  = 0

  return
end
function stkst ( nfact )

!*****************************************************************************80
!
!! STKST returns statistics on the state of the stack.
!
!  Discussion:
!
!    this routine replaces function istkst in the framework
!    for use with starpac.  returns one of four statistics on the
!    state of the cstak stack.
!
!    this routine assumes that the stack is initialized.
!    it does not check to see if it is.  in fact, there
!    is no way that it could check.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     nfact
  integer stkst
!
!  arrays in common
  double precision dstak(12)
!
!  local arrays
  integer &
     istak(12),istats(4)
!
!  common blocks
  common /cstak/dstak
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (istak(1),istats(1))
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer istats(4)
!        integer array including the four stack statistics.
!     integer nfact
!
  if ( nfact <= 0 .or. 6 <= nfact ) then
    write ( *, 1000) nfact
    stkst = 0
    return
  end if
!
!  report true value of a statistic, assuming stack is
!  defined.
!
  stkst = istats(nfact)

  return

 1000 format (///' ***** error *****'// &
     ' illegal stack statistic', i5, ' requested.')
end
function stopx ( )

!***********************************************************************
!
!! STOPX is called to stop execution.
!
!  Discussion:
!
!    This function may serve as the STOPX (asynchronous interruption)
!    function for the NL2SOL package at those installations which do not
!    wish to implement a dynamic STOPX.
!
!    At installations where the NL2SOL system is used
!    interactively, this dummy STOPX should be replaced by a
!    function that returns TRUE if and only if the interrupt
!    (break) key has been pressed since the last call on STOPX.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
  implicit none

  logical stopx

  stopx = .false.

  return
end
subroutine stpadj ( xm, n, m, ixm, mdl, par, npar, &
     nexmpt, stp, nfail, ifail, j, reltol, abstol, stplow, stpmid, &
     stpup, itemp, fd, fdlast, pv, pvnew )

!*****************************************************************************80
!
!! STPADJ adjusts the selected step sizes to optimal values.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     abstol,reltol,stp,stplow,stpmid,stpup
  integer &
     ixm,j,m,n,nexmpt,nfail,npar
!
!  array arguments
  real &
     fd(n),fdlast(n),par(npar),pv(n),pvnew(n),xm(ixm,m)
  integer &
     ifail(n),itemp(n)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  real &
     q

  real &
     factor,stpnew,temp
  integer &
     ncount
  logical &
     done,first
!
!  external subroutines
  external cmpfd,icopy,relcom,scopy
!
!  common blocks
  common /notopt/ q
!
!     variable definitions (alphabetically)
!
!     real abstol
!        the absolute agreement tolerance.
!     logical done
!        the variable used to indicate whether the adjustment
!        process is complete or not.
!     real factor
!        a factor used in computing the step size.
!     real fd(n)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!     real fdlast(n)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!        computed with the most recent step size selected.
!     logical first
!        the variable used to indicate whether this step size
!        is being used for the first time or whether it has been
!        previously adjusted.
!     integer ifail(n)
!        an indicator vector used to designate those observations
!        for which the step size does not meet the criteria.
!     integer itemp(n)
!        a temporary vector used for storing past values of itemp.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the parameter being examined.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     integer ncount
!        the number of observations at which the new step size does
!        satisfy the criteria.
!     integer nexmpt
!        the number of observations for which a given step size
!        does not have to be satisfactory and the selected step
!        size still be considered ok.
!     integer nfail
!        a vector containing for each observation the number of
!        observations for which the step size did not meet the criteria.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real pvnew(n)
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpcd.
!     real q
!        a dummy variable which is used, along with common notopt (no
!        optimization), to compute the step size.
!     real reltol
!        the relative agreement tolerance.
!     real stp
!        the step size currently being examined for the forward
!        difference approximation to the derivative.
!     real stplow
!        the lower limit on the step size.
!     real stpmid
!        the midpoint of the acceptable range of the step size.
!     real stpnew
!        the value of the new step size being tested.
!     real stpup
!        the upper limit on the step size.
!     real temp
!        a temporary location in which the current estimate of the jth
!        parameter is stored.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  call icopy(n, ifail, 1, itemp, 1)
  ncount = nfail

  if ((stplow <= abs(stp)) .and. (abs(stp) <= stpup)) return

  if (abs(stp) > stpmid) then

        stpnew = stpup * sign(1.0e0, par(j))
        factor = 10.0e0
  else

        stpnew = stplow * sign(1.0e0, par(j))
        factor = 0.1e0

  end if

  q = stpnew + par(j)
  stpnew = q - par(j)

  done = .false.
  first = .true.

  do

    call scopy(n, fd, 1, fdlast, 1)

    temp = par(j)
    par(j) = temp + stpnew
    call mdl(par, npar, xm, n, m, ixm, pvnew)
    par(j) = temp

    call cmpfd(n, stpnew, pvnew, pv, fd)

    call relcom ( n, fd, fdlast, reltol, abstol, ncount, itemp )

    if (ncount <= nexmpt) then

      done = .true.
      call icopy(n, itemp, 1, ifail, 1)
      nfail = ncount

      if (first) then
        stp = stpnew
      else
        stp = stpnew / factor
      end if

    else

      first = .false.
      stpnew = stpnew * factor
      q = stpnew + par(j)
      stpnew = q - par(j)

      if ((factor > 1.0e0 .and. abs(stpnew) > abs(stp)) .or. &
          (factor<1.0e0 .and. abs(stpnew)<abs(stp))) then
        done = .true.
      end if

    end if

    if (done) then
      exit
    end if

  end do

  return
end
subroutine stpamo ( head, n, exm, nexmpt, neta, j, par, npar, stp, &
  nfail, ifail, scale, lscale, hdr, page, wide, isubhd, nprt, &
  prtfxd, ifixd )

!*****************************************************************************80
!
!! STPAMO is a dummy routine for the ARIMA estimation routines.
!
!  Discussion:
!
!    The user should use this routine as a template to write a
!    routine that can be used to print out interim data for
!    ARIMA estimations.
!
!    Ignore compiler warning messages about unused variables!
!
!  Modified:
!
!    19 April 2007
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real exm
!        the proportion of observations actually used for which the
!        computed numerical derivatives wrt a given parameter are
!        exempted from meeting the derivative acceptance criteria.
!     external hdr
!        the name of the routine which produces the heading
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ifail(n)
!        the array of indicator variables designating whether
!        the step size selected was satisfactory for a given
!        observation and parameter.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixd(i) /= 0, then par(i) will be optimized.  if
!        ifixd(i) == 0, then par(i) will be held fixed.
!     integer isubhd
!     integer j
!        the index of the parameter being examined.
!     integer lscale
!        the length of vector scale.
!     integer n
!        the number of observations.
!     integer npar
!        the number of parameters in the model.
!     integer neta
!        the number of reliable digits in the model.
!     integer nexmpt
!        the number of observations for which a given step size
!        does not have to be satisfactory and the selected step
!        size still be considered ok.
!     integer nfail(npar)
!        the number of observations for which the selected step
!        size does not meet the criteria.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     logical page
!        the variable used to indicate whether or not the output
!        is to begin on a new page.
!     real par(npar)
!        the array in which the current estimates of the
!        parameters are stored.
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real scale(lscale)
!        the typical size of the parameters.
!     real stp(npar)
!        the selected step size.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  implicit none

  integer lscale
  integer n
  integer npar

  real exm
  external hdr
  logical head
  integer ifail(n)
  integer ifixd(npar)
  integer isubhd
  integer j
  integer neta
  integer nexmpt
  integer nfail(npar)
  integer nprt
  logical page
  real par(npar)
  logical prtfxd
  real scale(lscale)
  real stp(npar)
  logical wide

  return
end
subroutine stpcnt ( xm, n, m, ixm, mdl, par, npar, stp, &
  exmpt, neta, scale, lscale, nprt, hdr, page, wide, isubhd, &
  hlfrpt, prtfxd, ifixed, lifixd )

!*****************************************************************************80
!
!! STPCNT controls the stepsize selection process.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     exmpt
  integer &
     isubhd,ixm,lifixd,lscale,m,n,neta,npar,nprt
  logical &
     hlfrpt,page,prtfxd,wide
!
!  array arguments
  real &
     par(npar),scale(lscale),stp(npar),xm(ixm,m)
  integer &
     ifixed(lifixd)
!
!  subroutine arguments
  external hdr,mdl
!
!  scalars in common
  real &
     q
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  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
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external cpyvii,etamdl,setiv,stkclr,stpmn,stpout
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
  common /notopt/q
!
!  equivalences
  equivalence (dstak(1),istak(1))
  equivalence (dstak(1),rstak(1))
!
!     variable definitions (alphabetically)
!
!     integer cd
!        the starting location in the work area of
!        the central difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real eta
!        the relative noise in the model
!     real exm
!        the proportion of observations actually used for which the
!        computed numerical derivatives wrt a given parameter are
!        exempted from meeting the derivative acceptance criteria.
!     real exmpt
!        the proportion of observations for which the computed
!        numerical drvatives wrt a given parameter are exempted
!        from meeting the derivative acceptance criteria.
!     integer fd
!        the starting location in the work area of
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     integer fdlast
!        the starting location in the work area of
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!        for the last step size tried.
!     integer fdsave
!        the starting location in the work area of
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!        for the best step size tried so far.
!     real fplrs
!        the floating point largest relative spacing.
!     external hdr
!        the name of the routine which produces the heading
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     logical hlfrpt
!        the variable which indicates whether the step size selection
!        routine has already printed part of the initial summary (true)
!        or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifailj
!        the starting location in istak for
!        the array of indicator variables designating whether
!        the setp size selected was satisfacotry for a given
!        observation and the jth parameter.
!     integer ifixd
!        the starting location in istak of
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.
!     integer ifixed(lifixd)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer itemp
!        the starting location in istak for
!        a temporary storage vector.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the parameter being examined.
!     integer lifixd
!        the length of the vector ifixed.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer mxfail
!        the maximum number of failures for any parameter.
!     integer n
!        the number of observations.
!     integer nall0
!        the number of stack allocations on entry.
!     integer ndd
!        the number of decimal digits carried for a real
!        numbers.
!     integer ndgt1
!        the number of reliable digits in the model used, either
!        set to the user supplied value of neta, or computed
!        by etamdl.
!     integer neta
!        the user supplied number of reliable digits in the model.
!     integer nexmpt
!        the number of observations for which a given step size
!        does not have to be satisfactory and the selected step
!        size still be considered ok.
!     integer nfail
!        the number of observations for which the selected step size
!        for the parameter does not meet the criteria.
!     integer nfailj
!        the number of observations for which the selected step size
!        for the jth parameter does not meet the criteria.
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     integer partmp
!        the starting location in the work area of
!        the modified model parameters
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     integer pv
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!     integer pvmcd
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!     integer pvnew
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpnew.
!     integer pvpcd
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpcd.
!     integer pvstp
!        the starting location in the work area of
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stp(j).
!     integer pvtemp
!        the starting location in the work area of
!        a tempory storage location for predicted values begins.
!     real q
!        a dummy variable which is used, along with common notopt (no
!        optimization), to compute the step size.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real scale(lscale)
!        the typical size of the parameters.
!     real scl
!        the actual typical size used.
!     real stp(npar)
!        the selected step sizes.
!     real tau
!        the agreement tolerance.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  nall0 = stkst(1)

  fplrs = epsilon ( fplrs )
  ifp = 3
!
!  set print controls
!
  head = .true.
!
!  subdivide work area
!
  ifixd = stkget(npar, 2)
  itemp = stkget(n, 2)
  ifailj = stkget(n, 2)
  nfail = stkget(npar, 2)

  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)

  if (ierr == 1) return

  partmp = cd
!
!  set up ifixd
!
  if (ifixed(1)<0) then
     call setiv(istak(ifixd), npar, 0)
  else
     call cpyvii(npar, ifixed, 1, istak(ifixd), 1)
  end if
!
!  set parameters necessary for the computations
!
  ndd = int(-log10(fplrs))

  if ((neta >= 2) .and. (neta <= 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

  tau = min(eta ** (0.25e0), 0.01e0)

  exm = exmpt
  if ((exm<0.0e0) .or. (exm > 1.0e0)) exm = 0.10e0
  nexmpt = int ( exm * real ( n ) )
  if (exm  /=  0.0e0) then
    nexmpt = max(nexmpt, 1)
  end if
!
!  compute predicted values of the model using the input parameter
!  estimates
!
  call mdl(par, npar, xm, n, m, ixm, rstak(pv))

  mxfail = 0
  nfailj = nfail

  do j = 1, npar

     if (istak(ifixd-1+j) == 0) then
        if (scale(1) <= 0.0e0) then
           if (par(j) == 0.0e0) then
              scl = 1.0e0
           else
              scl = abs(par(j))
           end if
        else
           scl = scale(j)
        end if

        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) )
!
!  compute the maximum number of failures for any parameter
!
        mxfail = max(istak(nfailj), mxfail)

     else
        stp(j) = 0.0
     end if
!
!  print results if they are desired
!
     if ((nprt /= 0) .or. (mxfail > 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

  end do

  hlfrpt = .false.
  if ((nprt /= 0) .or. (mxfail > nexmpt)) hlfrpt = .true.

  if (mxfail > nexmpt) ierr = 2

  call stkclr(nall0)

  return
end
subroutine stpdrv ( nmsub, xm, n, m, ixm, mdl, par, npar, ldstak, &
     stp, neta, exmpt, scale, lscale, nprt )

!*****************************************************************************80
!
!! STPDRV is the driver for selecting forward difference step sizes.
!
!  Discussion:
!
!     this is the driver routine for selecting step sizes
!     to be used in computing forward difference quotient estimates
!     of the numerical derivatives.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     exmpt
  integer &
     ixm,ldstak,lscale,m,n,neta,npar,nprt
!
!  array arguments
  real &
     par(*),scale(*),stp(*),xm(*)
  character &
     nmsub(6)*1
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     isubhd,lifixd
  logical &
     hlfrpt,page,prtfxd,wide
!
!  local arrays
  integer &
     ifixed(1)
!
!  external subroutines
  external stkset,stpcnt,stper,stphdr
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real exmpt
!        the proportion of observations for which the computed
!        numerical derivatives wrt a given parameter are excepted
!        from meeting the derivative acceptance criteria.
!     logical hlfrpt
!        the variable which indicates whether the step size selection
!        routine has already printed part of the initial summary (true)
!        or not (false).
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ifixed(1)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixed(i) /= 0, then par(i) will be optimized.  if
!        ifixed(i) == 0, then par(i) will be held fixed.
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lifixd
!        the length of the vector ifixed.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer neta
!        the number of accurate digits in the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     real scale(lscale)
!        the typical size of the unknown parameters.
!     real stp(npar)
!        the selected step sizes.
!     external stphdr
!        the name of the routine which produces the heading
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!     real xm(ixm,m)
!        the independent variable array
!
  call stper(nmsub, n, m, ixm, npar, ldstak, scale, lscale)

  if (ierr /= 0) return

  call stkset(ldstak, 4)

  page = .false.
  wide = .true.
  isubhd = 0

  prtfxd = .false.
  ifixed(1) = -1
  lifixd = 1
!
!  pass control of step size selection to subroutine stpcnt
!
  call stpcnt(xm, n, m, ixm, mdl, par, npar, stp, exmpt, neta, &
     scale, lscale, nprt, stphdr, page, wide, isubhd, hlfrpt, &
     prtfxd, ifixed, lifixd)

  return
end
subroutine stper ( nmsub, n, m, ixm, npar, ldstak, scale, lscale )

!*****************************************************************************80
!
!! STPER does error checking for the stepsize selection routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,ldstak,lscale,m,n,npar
!
!  array arguments
  real &
     scale(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,ldsmin,nv
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,ervgt,ldscmp
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical error(10)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldsmin
!        the minimum length allowed for the array dstak.
!     integer ldstak
!        the length of the array dstak.
!     character*1 lixm(8), llds(8), lm(8), ln(8), lnpar(8), lone(8),
!    +            lscl(8), lzero(8)
!        the array(s) containing the name(s) of input parameter(s)
!        checked for errors.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nv
!        the number of violations found.
!     real scale(lscale)
!        the typical size of the unknown parameters.
!
!     set up name arrays
!
  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',' ',' ',' ',' '/

  error(1:10) = .false.
  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 1, 2, head, error(1), lone)

  call eisge(nmsub, lm, m, 1, 2, head, error(2), lone)

  call eisge(nmsub, lixm, ixm, n, 3, head, error(3), ln)

  call eisge(nmsub, lnpar, npar, 1, 2, head, error(4), lone)

  call ldscmp(14, 0, 2*(n+npar), 0, 0, 0, 's', 9*n + max(n,npar), &
              ldsmin)

  if ((.not.error(1)) .and. (.not.error(4))) &
     call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(5), &
     llds)

  call ervgt(nmsub, lscl, scale, lscale, 0.0e0, 0, head, 6, nv, &
     error(9), lzero)

  do i=1,10
    if (error(i)) then
      ierr = 1
    end if
  end do

  return
end
subroutine stphdr ( page, wide, isubhd )

!*****************************************************************************80
!
!! STPHDR prints page headings for the stepsize selection routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     isubhd
  logical &
     page,wide
!
!  external subroutines
  external versp
!
!     variable definitions (alphabetically)
!
!     integer isubhd
!        an indicator value specifying subheadings to be printed.
!     logical page
!        the variable used to indicate whether a given section of
!        the output is to begin on a new page (true) or not (false).
!     logical wide
!       the variable used to indicate whether the heading should
!        full width (true) or not (false).
!
  if (page) write ( *, 1020)
  call versp(wide)
  if (page) write ( *,1000)
  if (.not.page) write ( *,1010)
  page = .true.

  if (isubhd == 0) return

  write ( *, 1030)

  return

 1000 format ('+derivative step size selection continued')
 1010 format ('+', 34('*')/ ' * derivative step size selection *'/ &
     1x, 34('*'))
 1020 format ('1')
 1030 format (//' summary of initial conditions'/ 1x, 30('-'))
end
subroutine stpls1 ( n, m, ixm, par, npar, neta, exmpt, scale, nprt )

!*****************************************************************************80
!
!! STPLS1 sets a test problem for the step size selection family.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real exmpt
!        the proportion of observations for which the computed
!        numerical derivatives wrt a given parameter are exempted
!        from meeting the derivative acceptance criteria.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer m
!        the number of independent variables.
!     integer n
!        the number of observations.
!     integer neta
!        the number of reliable digits in the model.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nprt
!        the parameter used to indicate how much printed output is
!        to be provided.
!     real par(10)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real scale(10)
!        a value to indicate use of the default values of
!        the typical size of the unknown parameters.
!
  implicit none

  real &
     exmpt
  integer &
     ixm,m,n,neta,npar,nprt
!
!  array arguments
  real &
     par(10),scale(10)

  par(1) = 0.0e0
  par(2) = 3.125e0
  par(3) = 1.0e0
  par(4) = 2.0e0

  n = 101
  m = 1
  ixm = 200
  npar = 4
  scale(1:10) = 1.0e0
  neta = 0
  exmpt = 0.0e0
  nprt = 1

  return
end
subroutine stpls2 ( npar, stp )

!*****************************************************************************80
!
!! STPLS2 sets a test problem for the step size selection family.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer npar
!        the number of unknown parameters in the model.
!     real stp(npar)
!        the step size array.
!
  implicit none

  integer &
     npar
!
!  array arguments
  real &
     stp(npar)
!
!  scalars in common
  integer &
     ierr
!
!  common blocks
  common /errchk/ierr

  stp(1:npar) = -1.0e0

  ierr = -1

  return
end
subroutine stplsc ( xm, n, m, ixm, mdl, par, npar, ldstak, stp, &
     neta, exmpt, scale, nprt )

!*****************************************************************************80
!
!! STPLSC selects step sizes for forward difference estimates of derivatives.
!
!  Discussion:
!
!    this is the user callable subroutine for selecting step sizes
!    to be used in computing forward difference quotient estimates
!    of the numerical derivatives for the nonlinear least squares
!    routines (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     exmpt
  integer &
     ixm,ldstak,m,n,neta,npar,nprt
!
!  array arguments
  real &
     par(*),scale(*),stp(*),xm(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  integer &
     lscale
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external stpdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real exmpt
!        the proportion of observations for which the computed
!        numerical derivatives wrt a given parameter are exempted
!        from meeting the derivative acceptance criteria.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer neta
!        the number of accurate digits in the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     real par(npar)
!        the array in which the current estimates of the
!        parameters are stored.
!     real scale(npar)
!        the typical size of the parameters.
!     real stp(npar)
!        the selected step sizes.
!     real xm(ixm,m)
!        the independent variable array
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     's','t','p','l','s','c'/
!
!  set length of vector scale.
!
  lscale = npar
!
!  pass control to step size selection driver
!
  call stpdrv(nmsub, xm, n, m, ixm, mdl, par, npar, ldstak, stp, &
     neta, exmpt, scale, lscale, nprt)

  if (ierr /= 1) return

  write ( *,1000)

  return

 1000 format (/' the correct form of the call statement is'// &
   '       call stplsc (xm, n, m, ixm, nlsmdl, par, npar, ldstak,', &
   ' stp,'/ &
   '      +             neta, exmpt, scale, nprt)')
end
subroutine stpls ( xm, n, m, ixm, mdl, par, npar, ldstak, stp )

!*****************************************************************************80
!
!! STPLS selects step sizes for estimating derivatives in NLS routines.
!
!  Discussion:
!
!    this is the user callable subroutine for selecting step sizes
!    to be used in computing forward difference quotient estimates
!    of the numerical derivatives for the nonlinear least squares
!    routines (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ixm,ldstak,m,n,npar
!
!  array arguments
  real &
     par(*),stp(*),xm(*)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     exmpt
  integer &
     lscale,neta,nprt
!
!  local arrays
  real &
     scale(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external stpdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real exmpt
!        the proportion of observations for which the computed
!        numerical derivatives wrt a given parameter are excepted
!        from meeting the derivative acceptance criteria.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors were detected.
!     integer ixm
!        the first dimension of the independent variable array xm.
!     integer ldstak
!        the length of the array dstak.
!     integer lscale
!        the length of vector scale.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer neta
!        the number of accurate digits in the model.
!     character*1 nmsub(6)
!        the name of the subroutine calling the error checking
!        subroutines.
!     integer npar
!        the number of parameters in the model.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     real par(npar)
!        the array in which the current estimates of the
!        parameters are stored.
!     real scale(1)
!        a dummy vector used to designate use of the default values of
!        the typical size of the parameters.
!     real stp(npar)
!        the selected step sizes.
!     real xm(ixm,m)
!        the independent variable array
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     's','t','p','l','s',' '/

  exmpt = 0.1e0
  neta = 0
  scale(1) = 0.0e0
  lscale = 1
  nprt = 1
!
!  pass control to step size selection driver
!
  call stpdrv(nmsub, xm, n, m, ixm, mdl, par, npar, ldstak, stp, &
     neta, exmpt, scale, lscale, nprt)

  if (ierr == 1 ) then
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call stpls (xm, n, m, ixm, nlsmdl, par, npar, ldstak,', &
     ' stp)')
end
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 )

!*****************************************************************************80
!
!! STPMN: main routine for numerical derivative step size selection.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!     variable definitions (alphabetically)
!
!     real abstol
!        the absolute agreement tolerance.
!     real cd(n)
!        the central difference quotient approximation to the
!        derivative of the model with respect to the jth parameter.
!     real curve
!        a measure of the curvature of the model.
!     real eta
!        the relative noise in the model
!     real eta3
!        the cube root of eta.
!     real fd(n)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!     real fdlast(n)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!        computed with the most recent step size selected.
!     real fdsave(n)
!        a vector used to save the best of the
!        the forward difference quotient approximations to the
!        derivative of the model with respect to the jth parameter
!     real fplrs
!        the floating point largest relative spacing.
!     integer i
!        an index variable.
!     integer ifail(n)
!        the vector of indicator variables designating whether
!        the step size selected was satisfactory for a given
!        observation and parameter.
!     integer itemp(n)
!        a temporary storage vector.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the parameter being examined.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     integer nexmpt
!        the number of observations for which a given step size
!        does not have to be satisfactory and the selected step
!        size still be considered ok.
!     integer nfail
!        the vector containing the counts for each parameter
!        of the number of observations the selected step size was
!        not satisfactory.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real parmx
!        the maximum of the current parameter estimate and the
!        typical value of that parameter
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real pvmcd(n)
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)-stpcd.
!     real pvmean
!        the mean of a function of the predicted values.
!     real pvnew(n)
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpnew.
!     real pvpcd(n)
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpcd.
!     real pvstp(n)
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stp.
!     real pvtemp(n)
!        a temporary storage vector for predicted values.
!     real pvtyp
!        the typical size of the predicted values of the model.
!     real q
!        a dummy variable which is used, along with common notopt (no
!        optimization), to compute the step size.
!     real scale
!        the typical size of the jth parameter.
!     real stp
!        the step size currently being examined for the forward
!        difference approximation to the derivative.
!     real stpcd
!        the step size used for the central difference quotient.
!     real stplow
!        the lower limit on the step size.
!     real stpmid
!        the midpoint of the acceptable range of the step size.
!     real stpup
!        the upper limit on the step size.
!     real reltol
!        the relative agreement tolerance.
!     real tauabs
!        the absolute agreement tolerance.
!     real temp
!        a temporary location in which the current estimate of the jth
!        parameter is stored.
!     real third
!        the value one third.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  integer ixm
  integer m
  integer n
  integer npar

  real cd(n)
  real eta
  real fd(n)
  real fdlast(n)
  real fdsave(n)
  integer ifail(n)
  integer itemp(n)
  integer j
  external mdl
  integer nexmpt
  integer nfail
  real par(npar)
  real pv(n)
  real pvmcd(n)
  real pvnew(n)
  real pvpcd(n)
  real pvstp(n)
  real pvtemp(n)
  real q
  real reltol
  real scale
  real stp
  real xm(ixm,m)

  real &
     abstol,curve,eta3,fplrs,parmx,pvmean,pvtyp,stpcd,stplow, &
     stpmid,stpup,tauabs,temp,third
  integer &
     i
!
!  external subroutines
  external cmpfd,gmean,relcom,stpadj,stpsel
!
!  common blocks
  common /notopt/ q

  fplrs = epsilon ( fplrs )

  third = 1.0e0 / 3.0e0

  eta3 = eta ** third

  parmx = max ( abs ( par(j) ), abs ( scale ) )
  if ( parmx == 0.0e0 ) then
    parmx = 1.0e0
  end if

  stpcd = ( ( 3.0e0 ** third ) * eta3 * parmx * sign ( 1.0e0, par(j) ) )

  q = stpcd + par(j)
  stpcd = q - par(j)

  temp = par(j)

  par(j) = temp + stpcd
  call mdl ( par, npar, xm, n, m, ixm, pvpcd )

  par(j) = temp - stpcd
  call mdl ( par, npar, xm, n, m, ixm, pvmcd )

  par(j) = temp
!
!  Estimate curvature by second derivative of model with respect to PAR(J).
!
  do i = 1, n
     pvtemp(i) = abs( ( pvpcd(i) + pvmcd(i) ) - 2.0 * pv(i) )
     if ( pvtemp(i) == 0.0e0 ) then
        if ( pv(i) == 0.0e0 ) then
           pvtemp(i) = fplrs
        else
           pvtemp(i) = fplrs * abs ( pv(i) )
        end if
     end if
  end do
!
!  Compute the geometric mean
!
  call gmean ( pvtemp, n, pvmean )

  curve = abs(pvmean / stpcd / stpcd)
!
!  compute a typical value of the model
!
  do i = 1, n
     pvtemp(i) = abs(pvpcd(i) + pv(i) + pvmcd(i))
     if (pvtemp(i) == 0.0e0) then
        if (pv(i) == 0.0e0) then
           pvtemp(i) = fplrs
        else
           pvtemp(i) = fplrs*abs(pv(i))
        end if
     end if
  end do

  call gmean(pvtemp, n, pvmean)

  pvtyp = abs(pvmean / 3.0e0)
!
!  set values representative of the range the step size
!  can be expected to take
!
  stpup = (eta3) * parmx
  stplow = (eta3) * stpup
  stpmid = sqrt(stplow) * sqrt(stpup)
!
!  Select an optimum starting step size.
!
  if ( curve == 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

  if ( abs(stp) > parmx ) then
    stp = parmx * sign(1.0e0,par(j))
  end if

  q = stp + par(j)
  stp = q - par(j)

  if ( stp == 0.0e0 ) then

    stp = fplrs * par(j)

    if ( stp == 0.0e0 ) then
      stp = fplrs
    end if

    do

      q = stp + par(j)
      stp = q - par(j)

      if ( stp /= 0.0 ) then
        exit
      end if

      stp = 2.0e0 * stp

    end do

  end if
!
!  Compute the absolute tolerances.
!
  abstol = 10.0e0 * eta * pvtyp

  tauabs = 2.0e0 * sqrt ( eta ) * sqrt ( pvtyp )
  if ( curve  /=  0.0e0 ) then
    tauabs = tauabs * sqrt(curve)
  end if

  temp = par(j)
  par(j) = temp + stp

  call mdl ( par, npar, xm, n, m, ixm, pvstp )

  par(j) = temp
!
!  Compute the forward and central difference quotient estimate
!  of the derivative.
!
  call cmpfd ( n, stp, pvstp, pv, fd )

  call cmpfd ( n, 2.0e0 * stpcd, pvpcd, pvmcd, cd )
!
!  Compute the number of observations for which the forward difference
!  does not agree with the central difference within the tolerance specified.
!
  call relcom ( n, fd, cd, reltol, abstol, nfail, ifail )
!
!  If the forward difference approximation does not agree within
!  tolerance for more than  NEXMPT observation, select new
!  value of the step size, else adjust the step size and return.
!
  if ( nfail > nexmpt ) then
!
!  Select new value of the step size.
!
    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
!
!  Adjust the current step size value.
!
    call stpadj ( xm, n, m, ixm, mdl, par, npar, &
      nexmpt, stp, nfail, ifail, j, reltol, abstol, stplow, &
      stpmid, stpup, itemp, fd, fdlast, pv, pvnew )

  end if
!
!  Convert selected absolute step size to relative step size.
!
  stp = abs ( stp ) / parmx

  return
end
subroutine stpout ( head, n, exm, nexmpt, neta, j, par, npar, stp, &
  nfail, ifail, scale, lscale, hdr, page, wide, isubhd, nprt, &
  prtfxd, ifixd )

!*****************************************************************************80
!
!! STPOUT prints results for the step size selection routines.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     character*1 blank
!        the character blank.
!     character*1 c
!        the character flag indicating high curvature.
!     real exm
!        the proportion of observations actually used for which the
!        computed numerical derivatives wrt a given parameter are
!        exempted from meeting the derivative acceptance criteria.
!     character*1 f
!        the character flag indicating number of observations
!        failing selection criteria exceeded exempted number.
!     character*1 fixed(3)
!        the characters used to label the parameters fixed or not.
!     external hdr
!        the name of the routine which produces the heading
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer i
!        an index variable.
!     integer ifail(n)
!        the array of indicator variables designating whether
!        the step size selected was satisfactory for a given
!        observation and parameter.
!     integer index(25)
!        the row numbers of observations for which the step size
!        selected failed.
!     integer ifixd(npar)
!        the indicator values used to designate whether the
!        parameters are to be optimized or are to be held fixed.  if
!        ifixd(i) /= 0, then par(i) will be optimized.  if
!        ifixd(i) == 0, then par(i) will be held fixed.
!     integer j
!        the index of the parameter being examined.
!     integer k
!        an index variable.
!     integer lscale
!        the length of vector scale.
!     integer n
!        the number of observations.
!     integer npar
!        the number of parameters in the model.
!     integer neta
!        the number of reliable digits in the model.
!     integer nexmpt
!        the number of observations for which a given step size
!        does not have to be satisfactory and the selected step
!        size still be considered ok.
!     integer nfail(npar)
!        the number of observations for which the selected step
!        size does not meet the criteria.
!     integer nflabs
!        the absolute value of nfail.
!     integer nk
!        an index variable.
!     integer nperl
!        the number of observations to be printed per line.
!     integer nprt
!        the indicator variable used to specify whether or not
!        printed output is to be provided, where if the value of
!        nprt is zero, no printed output is given.
!     logical page
!        the variable used to indicate whether or not the output
!        is to begin on a new page.
!     real par(npar)
!        the array in which the current estimates of the
!        parameters are stored.
!     character*1 plus
!        the character plus.
!     logical prtfxd
!        the indicator value used to designate whether the
!        output is to include information on whether the
!        parameter is fixed (true) or not (false).
!     logical sameln
!        an indicator value to designate whether the line is to be
!        printed on the same line as the previous line printed (true)
!        or not (false).
!     real scale(lscale)
!        the typical size of the parameters.
!     real stp(npar)
!        the selected step size.
!     logical wide
!        the variable used to indicate whether the heading should
!        be full width (true) or not (false).
!
  implicit none

  integer lscale
  integer n
  integer npar

  real exm
  character fixed(3)
  external hdr
  logical head
  integer ifail(n)
  integer ifixd(n)
  integer isubhd
  integer j
  integer neta
  integer nexmpt
  integer nfail(npar)
  integer nprt
  logical page
  real par(npar)
  logical prtfxd
  real scale(lscale)
  real stp(npar)
  logical wide

  integer &
     i,k,nflabs,nk,nperl
  logical &
     sameln
  character &
     blank*1,c*1,f*1,plus*1
!
!  local arrays
  integer &
     index(25)

  data blank /' '/, plus /'+'/

  fixed(1:3) = ' '
!
!  Print heading
!
  if ( head ) then

    head = .false.

    call hdr ( page, wide, isubhd )

    if (prtfxd) then
      write ( *,1000)
    else
      write ( *,1010)
    end if
!
!  Print information otherwise suppressed by print control
!
    do i=1,j-1

      if (prtfxd) call fixprt(ifixd(i), fixed)

      if (ifixd(i) == 0) then
        f = ' '
        c = ' '
        nflabs = iabs(nfail(i))
        if (nflabs > nexmpt) f = '+'
        if (nfail(i)<0) c = '+'
        if (scale(1) > 0.0e0) then
          write ( *,1020) i, (fixed(k),k=1,3), par(i), &
            scale(i), stp(i), nflabs, f, c
        else
          write ( *,1040) i, (fixed(k),k=1,3), par(i), &
            stp(i), nflabs, f, c
        end if

        if (nflabs > nexmpt) then
          write ( *,1030)
        end if

      else
        write ( *,1045) i, (fixed(k),k=1,3), par(i)
      end if

    end do

  end if
!
!  print information for current parameter
!
  i = j

  if ( prtfxd ) then
    call fixprt(ifixd(i), fixed)
  end if

  if (ifixd(i) == 0) then
     f = ' '
     c = ' '
     nflabs = iabs(nfail(i))
     if (nflabs > nexmpt) f = '+'
     if (nfail(i)<0) c = '+'
     if (scale(1) > 0.0e0) then
        write ( *,1020) i, (fixed(k),k=1,3), par(i), &
                          scale(i), &
                          stp(i), nflabs, f, c
     else
        write ( *,1040) i, (fixed(k),k=1,3), par(i), &
                          stp(i), nflabs, f, c
     end if
     if (nflabs >= 1) then
        if ((nprt == 0) .and. (nflabs <= nexmpt)) then
           write ( *,1030)
        else
!
!  print row numbers
!
           nperl = 7

           sameln = .true.
           nk = 0

           do i=1,n

              if (ifail(i) == 0) then
                cycle
              end if

              nk = nk + 1
              index(nk) = i

              if (nk<nperl) then
                cycle
              end if

              if (sameln) then
                 write ( *,1050) (index(k),k=1,nk)
              else
                 write ( *,1060) (index(k),k=1,nk)
              end if
              sameln = .false.
              nk = 0

           end do

           if (sameln) then
              write ( *,1050) (index(k),k=1,nk)
           else
              write ( *,1060) (index(k),k=1,nk)
           end if

        end if
     end if
  else
     write ( *,1045) i, (fixed(k),k=1,3), par(i)
  end if

  if (j<npar) return
!
!  print final notes and summary
!
  write ( *,1070)

  if (nprt == 0) then

    do i=1,npar
      if (ifixd(i) == 0) then
        if (iabs(nfail(i)) <= nexmpt) then
          write ( *,1080)
          exit
        end if
      end if
    end do

  end if
!
!  Print control values used.
!
  write ( *,1090) neta
  write ( *,1100) exm
  write ( *,1110) nexmpt
  write ( *,1120) n

  return

 1000 format (//50x, 'step size for', 4x, 'observations failing step', &
     ' size selection criteria'/50x, 'approximating', 21x, '*'/7x, &
     'parameter starting value', 6x, 'scale', 10x, 'derivative', &
     7x, 'count', 5x, 'notes', 5x, 'row number'/1x, 'index', 2x, &
     'fixed', 6x, '(par)', 12x, '(scale)', 11x, '(stp)', 21x, 'f c'/ &
     )
 1010 format (//50x, 'step size for', 4x, 'observations failing step', &
     ' size selection criteria'/18x, 'parameter', 23x, 'approxima', &
     'ting', 21x, '*'/16x, 'starting value', 7x, 'scale', 10x, &
     'derivative', 7x, 'count', 5x, 'notes', 5x, 'row number(s)'/ &
     1x, 'index', 13x, '(par)', 12x, '(scale)', 11x, '(stp)', 21x, &
     'f c'/)
 1020 format (1x, i3, 5x, 3a1, 3g17.8, 5x, i5, 7x, a1, 1x, a1)
 1030 format ('+', 89x, '**')
 1040 format (1x, i3, 5x, 3a1, g17.8, 7x, 'default', 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, '*  notes.  a plus (+) in the columns', ' headed ', &
     'f or c has the following meaning.'//4x, 'f - number of obs', &
     'ervations failing step size', ' selection criteria exceeds'/ &
     8x, 'number of exemptions allowed.'//4x, 'c - high curvatur', &
     'he in the model is suspected as', ' the cause of'/8x, &
     'all failures noted.')
 1080 format (//' ** row numbers are only listed when number of', &
     ' observations failing step'/4x, 'size selection criteria e', &
     'xceeds number of exemptions', ' allowed.')
 1090 format (/' number of reliable digits in model results', 25x, &
     '(neta)', 1x, i5)
 1100 format (/' proportion of observations exempted from', ' selecti', &
     'on criteria', 7x, '(exmpt)', 2x, f6.4)
 1110 format (/' number of observations exempted from', ' selection ', &
     'criteria', 19x, i5)
 1120 format (/' number of observations', 48x, '(n)', 1x, i5)
end
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 )

!*****************************************************************************80
!
!! STPSEL selects new step sizes until no further improvement can be made.
!
!  Discussion:
!
!    this subroutine selects new step sizes until either
!    the number of observations at which the selection criteria
!    is not met does not exceed nexmpt or until no further
!    improvement can be made.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson, Robert Schnabel,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!     variable definitions (alphabetically)
!
!     real abstol
!        the absolute agreement tolerance.
!     real eta3
!        the cube root of the relative noise in the model
!     real factor
!        a factor used in computing the step size.
!     logical fail
!        the variable used to indicate whether a step size
!        cannot be selected which will successfully meet the criteria.
!     real fd(n)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!     real fdlast(n)
!        the forward difference quotient approximation to the
!        derivative of the model with respect to the jth parameter
!        computed with the most recent step size selected.
!     real fdsave(n)
!        a vector used to save the best of the
!        the forward difference quotient approximations to the
!        derivative of the model with respect to the jth parameter
!     logical first
!        the variable used to indicate whether this step size
!        is being used for the first time or whether it has been
!        previously adjusted.
!     logical forwrd
!        the variable used to indicate the direction of change in
!        the step size.
!     integer ifail(n)
!        an indicator vector used to designate those observations
!        for which the step size does not meet the criteria.
!     integer itemp(n)
!        a temporary vector used for storing past values of itemp.
!     integer ixm
!        the first dimension of the independent variable array.
!     integer j
!        the index of the parameter being examined.
!     integer m
!        the number of independent variables.
!     external mdl
!        the name of the user supplied subroutine which computes the
!        predicted values based on the current parameter estimates.
!     integer n
!        the number of observations.
!     integer npar
!        the number of unknown parameters in the model.
!     integer ncount
!        the number of observations at which the new step size does
!        satisfy the criteria.
!     integer nexmpt
!        the number of observations for which a given step size
!        does not have to be satisfactory and the selected step
!        size still be considered ok.
!     integer nfail
!        a vector containing for each observation the number of
!        observations for which the step size did not meet the criteria.
!     real par(npar)
!        the array in which the current estimates of the unknown
!        parameters are stored.
!     real pv(n)
!        the predicted value based on the current parameter estimates
!     real pvnew(n)
!        the predicted value based on the current parameter estimates
!        for all but the jth parameter value, which is par(j)+stpcd.
!     real q
!        a dummy variable which is used, along with common notopt (no
!        optimization), to compute the step size.
!     real stp
!        the step size currently being examined for the forward
!        difference approximation to the derivative.
!     real stplow
!        the lower limit on the step size.
!     real stpmid
!        the midpoint of the acceptable range of the step size.
!     real stpnew
!        the value of the new step size being tested.
!     real stpup
!        the upper limit on the step size.
!     real stp1, stp2
!        temporary storage locations for step sizes.
!     logical succes
!        the variable used to indicate whether the step size
!        successfully meets the criteria used to select the step
!        sizes.
!     real reltol
!        the relative agreement tolerance.
!     real tauabs
!        the absolute agreement tolerance.
!     real temp
!        a temporary location in which the current estimate of the jth
!        parameter is stored.
!     real xm(ixm,m)
!        the array in which one row of the independent variable array
!        is stored.
!
  implicit none

  real &
     abstol,eta3,reltol,stp,stplow,stpmid,stpup,tauabs
  integer &
     ixm,j,m,n,nexmpt,nfail,npar
!
!  array arguments
  real &
     fd(n),fdlast(n),fdsave(n),par(npar),pv(n),pvnew(n),xm(ixm,m)
  integer &
     ifail(n),itemp(n)
!
!  subroutine arguments
  external mdl
!
!  scalars in common
  real &
     q

  real &
     factor,stp1,stp2,stpnew,temp
  integer &
     ncount
  logical &
     fail,first,forwrd,succes
!
!  external subroutines
  external abscom,cmpfd,icopy,relcom,scopy,stpadj
!
!  common blocks
  common /notopt/q

  call scopy(n, fd, 1, fdsave, 1)

  factor = 10.0e0
  if (abs(stp) > stpmid) factor = 0.1e0

  stpnew = stp * factor
  stp1 = stpnew
  stp2 = stpnew

  q = stpnew + par(j)
  stpnew = q - par(j)

  first = .true.
  forwrd = .true.
  succes = .false.
  fail = .false.

  nfail = n + 1
!
!  repeat following until (succes) or (fail)
!
  do

    call scopy(n, fd, 1, fdlast, 1)

    temp = par(j)
    par(j) = temp + stpnew

    call mdl(par, npar, xm, n, m, ixm, pvnew)

    par(j) = temp

    call cmpfd(n, stpnew, pvnew, pv, fd)

    call relcom ( n, fd, fdlast, reltol, abstol, ncount, itemp )

    if (ncount <= nexmpt) then

      succes = .true.
      nfail = ncount
      call icopy(n, itemp, 1, ifail, 1)

      if (abs(abs(stpnew) - stpmid) > abs(abs(stpnew/factor) - stpmid)) then
        stp = stpnew / factor
      else
        stp = stpnew
      end if

    else

      if (ncount<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)

      end if

      stpnew = stpnew * factor
      q = stpnew + par(j)
      stpnew = q - par(j)

      if ((factor > 1.0e0 .and. abs(stpnew) > stpup) .or. &
          (factor<1.0e0 .and. abs(stpnew)<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

    if ( succes .or. fail ) then
      exit
    end if

  end do

  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

              if (abs(stp1)<abs(stp2)) then
                    stp = stp1
                    return
              else
                    stp = stp2
                    return
              end if
        end if
  end if

  return
end
subroutine strco ( t, ldt, n, rcond, z, job )

!*****************************************************************************80
!
!! STRCO estimates the condition of a real triangular matrix.
!
!  Modified:
!
!    02 March 2006
!
!  Author:
!
!    FORTRAN90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, (Society for Industrial and Applied Mathematics),
!    3600 University City Science Center,
!    Philadelphia, PA, 19104-2688.
!    ISBN 0-89871-172-X
!
!  Parameters:
!
!    Input, real T(LDT,N), the triangular matrix.  The zero
!    elements of the matrix are not referenced, and the corresponding
!    elements of the array can be used to store other information.
!
!    Input, integer LDT, the leading dimension of the array T.
!
!    Input, integer N, the order of the matrix.
!
!    Output, real RCOND, an estimate of the reciprocal condition
!    of T.  For the system T*X = B, relative perturbations in T and B of size
!    EPSILON may cause relative perturbations in X of size EPSILON/RCOND.
!    If RCOND is so small that the logical expression
!      1.0E+00 + RCOND == 1.0E+00
!    is true, then T may be singular to working precision.  In particular,
!    RCOND is zero if exact singularity is detected or the estimate underflows.
!
!    Output, real Z(N) a work vector whose contents are usually
!    unimportant.  If T is close to a singular matrix, then Z is an
!    approximate null vector in the sense that
!      norm(A*Z) = RCOND * norm(A) * norm(Z).
!
!    Input, integer JOB, indicates the shape of T:
!    0, T is lower triangular.
!    nonzero, T is upper triangular.
!
  implicit none

  integer ldt
  integer n

  real ek
  integer i1
  integer j
  integer j1
  integer j2
  integer job
  integer k
  integer kk
  integer l
  logical lower
  real rcond
  real s
  real sasum
  real sm
  real t(ldt,n)
  real tnorm
  real w
  real wk
  real wkm
  real ynorm
  real z(n)

  lower = job == 0
!
!  Compute the 1-norm of T.
!
  tnorm = 0.0E+00

  do j = 1, n

    if ( lower ) then
      l = n + 1 - j
      i1 = j
    else
      l = j
      i1 = 1
    end if

    tnorm = max ( tnorm, sasum ( l, t(i1,j), 1 ) )

  end do
!
!  RCOND = 1/(norm(T)*(estimate of norm(inverse(T)))).
!
!  Estimate = norm(Z)/norm(Y) where T * Z = Y and T' * Y = E.
!
!  T' is the transpose of T.
!
!  The components of E are chosen to cause maximum local
!  growth in the elements of Y.
!
!  The vectors are frequently rescaled to avoid overflow.
!
!  Solve T' * Y = E.
!
  ek = 1.0E+00
  z(1:n) = 0.0E+00

  do kk = 1, n

    if ( lower ) then
      k = n + 1 - kk
    else
      k = kk
    end if

    if ( z(k) /= 0.0E+00 ) then
      ek = sign ( ek, -z(k) )
    end if

    if ( abs ( t(k,k) ) < abs ( ek - z(k) ) ) then
      s = abs ( t(k,k) ) / abs ( ek - z(k) )
      z(1:n) = s * z(1:n)
      ek = s * ek
    end if

    wk = ek - z(k)
    wkm = -ek - z(k)
    s = abs ( wk )
    sm = abs ( wkm )

    if ( t(k,k) /= 0.0E+00 ) then
      wk = wk / t(k,k)
      wkm = wkm / t(k,k)
    else
      wk = 1.0E+00
      wkm = 1.0E+00
    end if

    if ( kk /= n ) then

      if ( lower ) then
        j1 = 1
        j2 = k - 1
      else
        j1 = k + 1
        j2 = n
      end if

      do 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) )
      end do

      if ( s < sm ) then
        w = wkm - wk
        wk = wkm
        do j = j1, j2
          z(j) = z(j) + w * t(k,j)
        end do
      end if

    end if

    z(k) = wk

  end do

  z(1:n) = z(1:n) / sasum ( n, z, 1 )

  ynorm = 1.0E+00
!
!  Solve T * Z = Y.
!
  do kk = 1, n

    if ( lower ) then
      k = kk
    else
      k = n + 1 - kk
    end if

    if ( abs ( t(k,k) ) < abs ( z(k) ) ) then
      s = abs ( t(k,k) ) / abs ( z(k) )
      z(1:n) = s * z(1:n)
      ynorm = s * ynorm
    end if

    if ( t(k,k) /= 0.0E+00 ) then
      z(k) = z(k) / t(k,k)
    else
      z(k) = 1.0E+00
    end if

    if ( lower ) then
      i1 = k + 1
    else
      i1 = 1
    end if

    if ( kk < n ) then
      w = -z(k)
      call saxpy ( n-kk, w, t(i1,k), 1, z(i1), 1 )
    end if

  end do
!
!  Make ZNORM = 1.0.
!
  s = 1.0E+00 / sasum ( n, z, 1 )
  z(1:n) = s * z(1:n)
  ynorm = s * ynorm

  if ( tnorm /= 0.0E+00 ) then
    rcond = ynorm / tnorm
  else
    rcond = 0.0E+00
  end if

  return
end
subroutine strdi ( t, ldt, n, det, job, info )

!***********************************************************************
!
!! STRDI computes the determinant and inverse of a real triangular matrix.
!
!  Modified:
!
!    02 March 2006
!
!  Author:
!
!    FORTRAN90 translation by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, (Society for Industrial and Applied Mathematics),
!    3600 University City Science Center,
!    Philadelphia, PA, 19104-2688.
!    ISBN 0-89871-172-X
!
!  Parameters:
!
!    Input/output, real T(LDT,N).
!    On input, T contains the triangular matrix.  The zero elements of the
!    matrix are not referenced, and the corresponding elements of the array
!    can be used to store other information.
!    On output, T contains the inverse matrix, if requested.
!
!    Input, integer LDT, the leading dimension of T.
!
!    Input, integer N, the order of the matrix.
!
!    Output, real DET(2), the determinant of the matrix, if
!    requested.  The determinant = DET(1) * 10.0**DET(2), with
!    1.0 <= abs ( DET(1) ) < 10.0, or DET(1) == 0.
!
!    Input, integer JOB, specifies the shape of T, and the task.
!    010, inverse of lower triangular matrix.
!    011, inverse of upper triangular matrix.
!    100, determinant only.
!    110, determinant and inverse of lower triangular.
!    111, determinant and inverse of upper triangular.
!
!    Output, integer INFO.
!    If the inverse was requested, then
!    0, if the system was nonsingular;
!    nonzero, if the system was singular.
!
  implicit none

  integer ldt
  integer n

  real det(2)
  integer i
  integer info
  integer j
  integer job
  integer k
  real t(ldt,n)
  real temp
  real, parameter :: ten = 10.0E+00

  info = 0
!
!  Determinant.
!
  if ( job / 100 /= 0 ) then

    det(1) = 1.0E+00
    det(2) = 0.0E+00

    do i = 1, n

      det(1) = t(i,i) * det(1)

      if ( det(1) == 0.0E+00 ) then
        exit
      end if

      do while ( abs ( det(1) ) < 1.0E+00 )
        det(1) = ten * det(1)
        det(2) = det(2) - 1.0E+00
      end do

      do while ( ten <= abs ( det(1) ) )
        det(1) = det(1) / ten
        det(2) = det(2) + 1.0E+00
      end do

    end do

  end if

  if ( mod ( job / 10, 10 ) == 0 ) then
    return
  end if
!
!  Inverse of an upper triangular matrix.
!
  if ( mod ( job, 10 ) /= 0 ) then

    info = 0

    do k = 1, n

      if ( t(k,k) == 0.0E+00 ) then
        info = k
        exit
      end if

      t(k,k) = 1.0E+00 / t(k,k)
      t(1:k-1,k) = -t(1:k-1,k) * t(k,k)

      do j = k + 1, n
        temp = t(k,j)
        t(k,j) = 0.0E+00
        call saxpy ( k, temp, t(1,k), 1, t(1,j), 1 )
      end do

    end do
!
!  Inverse of a lower triangular matrix.
!
  else

    info = 0

    do k = n, 1, -1

      if ( t(k,k) == 0.0E+00 ) then
        info = k
        exit
      end if

      t(k,k) = 1.0E+00 / t(k,k)
      temp = -t(k,k)

      if ( k /= n ) then
        call sscal ( n-k, temp, t(k+1,k), 1 )
      end if

      do j = 1, k-1
        temp = t(k,j)
        t(k,j) = 0.0E+00
        call saxpy ( n-k+1, temp, t(k,k), 1, t(k,j), 1 )
      end do

    end do

  end if

  return
end
subroutine sumbs ( x, n, lo, mid, hi )

!*****************************************************************************80
!
!! SUMBS finds a zero or value closest to zero in a sorted vector.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     hi,lo,mid,n
!
!  array arguments
  real &
     x(n)

  integer &
     curhi,curlo
!
!     variable definitions (alphabetically)
!
!     integer curhi
!        the upper bound of the current interval.
!     integer curlo
!        the lower bound of the current interval.
!     integer hi
!        input parameter.  the upper bound of the initial
!        interval.
!     integer lo
!        input parameter.  the lower bound of the initial
!        interval.
!     integer mid
!        output parameter.  the midpoint of the current
!        interval, and on exit the point in the initial
!        interval closest to zero.
!     integer n
!        input parameter.  the length of the array x.
!     real x(n)
!        input parameter.  the array x in which the search for
!        a (near) zero value is made.
!
!     binary search of x for 0.0e0 or closest to it.
!
  curlo = lo
  curhi = hi
!
!  see if zero is out of the range x(lo) to x(hi).
!
  if ( 0.0 <= x(curlo) ) then
    mid = curlo
    return
  end if

  if ( x(curhi) <= 0.0e0 ) then
    mid = curhi
    return
  end if
!
!  locate either a zero or a pair of adjacent values between
!  which there lies a zero.
!
  do

    if ( curlo + 1  ==  curhi ) then
      if ( x(curhi) + x(curlo) <= 0.0e0 ) then
        mid = curhi
      else
        mid = curlo
      end if
      exit
    end if

    mid = (curlo+curhi)/2
    if (0.0e0<x(mid)) curhi = mid
    if (0.0e0 > x(mid)) curlo = mid

    if (0.0e0 == x(mid)) then
      exit
    end if

  end do

  return
end
subroutine sumds ( x, n, lo, mid, hi, xmeanw, sumda, sumd2, sumd3, sumd4 )

!*****************************************************************************80
!
!! SUMDS sums unweighted powers of differences from the mean of a sorted vector.
!
!  Discussion:
!
!    This routine calculates unweighted sums of powers of
!    differences from the weighted mean for a sorted
!    vector in which the midth element is the element
!    closest to zero.  used by the stat family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sumd2,sumd3,sumd4,sumda,xmeanw
  integer &
     hi,lo,mid,n
!
!  array arguments
  real &
     x(n)

  real &
     diff
  integer &
     curhi,curlo,i,irev
!
!     variable definitions (alphabetically)
!
!     integer curhi
!        the upper bound of the current interval.
!     integer curlo
!        the lower bound of the current interval.
!     real diff
!        the differences between x(i) and xmeanw.
!     integer hi
!        input parameter.  the upper bound of the initial
!        interval.
!     integer i
!        a loop parameter.
!     integer irev
!        a variable which runs in the same interval as i, but
!        in the reverse order.
!     integer lo
!        input parameter.  the lower bound of the initial
!        interval.
!     integer mid
!        input parameter.  the index of the element in x closest to
!        zero in value.  the point out from which the summing is
!        done.
!     integer n
!        input parameter.  the length of the array x.
!     real sumda
!        output parameter.  the sum of the absolute values of the
!        differences diff.
!     real sumd2
!        output parameter.  the sum of the squares of the
!        differences diff.
!     real sumd3
!        output parameter.  the sum of the cubes of the
!        differences diff.
!     real sumd4
!        output parameter.  the sum of the hypercubes of the
!        differences diff.
!     real x(n)
!        input parameter.  the data array x in which the sums are taken.
!     real xmeanw
!        input parameter.  the weighted mean of x.
!
!  initialize summation variables.
!
  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
!
!  sum outwards from the value nearest zero.  that is, sum from
!  the least in magnitude to the greatest.
!
  do

    if (curhi > hi .or. curlo<lo) then
      exit
    end if

    if (abs(x(curhi))<abs(x(curlo))) then
      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
    else
      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
    end if

  end do
!
!  sum up any values which may remain because of an off
!  center zero point.
!
  do 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
  end do

  do 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
  end do

  return
end
subroutine sumid ( x, n, xmean, sumdi )

!*****************************************************************************80
!
!! SUMID sums I * ( X(I) - XMEAN ).
!
!  Discussion:
!
!    a routine to calculate the sum of the products of i and the i th
!    difference among the elements of the vector x - xmean.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sumdi,xmean
  integer &
     n
!
!  array arguments
  real &
     x(n)
!
!
  real &
     diff
  integer &
     i
!
!     variable definitions (alphabetically)
!
!     real diff
!        the difference of a value of x and the weighted mean of x.
!     integer i
!        a loop index.
!     integer n
!        input parameter.  the number of elements in x.
!     real sumdi
!        output parameter.  the sum of the products of i and the
!        elements of the vector x - xmean.
!     real x(n)
!        input parameter.  the vector of n data values.
!     real xmean
!        input parameter.  the mean of x.
!
  sumdi = 0.0e0
  do i=1,n
     diff = x(i) - xmean
     sumdi = sumdi + real ( i ) * diff
  end do

  return
end
subroutine sumidw ( x, w, n, xmeanw, sumdi )

!*****************************************************************************80
!
!! SUMIDW: dot product of I and ( X(I) - XMEANW ).
!
!  Discussion:
!
!    a routine to calculate the sum of the products of i and the i th
!    difference among the elements of the vector x - xmeanw which
!    are not weighted zero.  (elements weighted zero do not
!    produce an increment in i.)
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!
!     variable definitions (alphabetically)
!
!     real diff
!        the difference of a value of x and the weighted mean of x.
!     real i
!        i counts from 1 to the number of non-zero weighted elements
!        found in x.
!     integer n
!        input parameter.  the number of elements in x.
!     real sumdi
!        output parameter.  the sum of the products of i and the
!        non-zero weighted elements of the vector x - xmeanw.
!     real w(n)
!        input parameter.  the weights vector for x.
!     real x(n)
!        input parameter.  the vector of n data values.
!     real xmeanw
!        input parameter.  the weighted mean of x.
!
  implicit none

  integer n

  real diff
  integer i
  integer k
  real sumdi
  real w(n)
  real x(n)
  real xmeanw

  i = 0
  sumdi = 0.0e0

  do k = 1, n

    if ( w(k) /= 0.0e0 ) then
      diff = x(k) - xmeanw
      i = i + 1
      sumdi = sumdi + real ( i ) * diff
    end if

  end do

  return
end
subroutine sumot ( sts, n, nnzw, wts )

!*****************************************************************************80
!
!! SUMOT reports the computation of 53 selected statistics.
!
!  Discussion:
!
!    this subroutine reports the results of a stat family
!    computation of 53 selected statistics.  there may or
!    may not be weights.
!
!
  implicit none

  integer &
     n,nnzw
  logical &
     wts
!
!  array arguments
  real &
     sts(53)

  integer &
     i
!
!  local arrays
  integer &
     itemp(10)
!
!  external subroutines
  external versp
!
!     variable definitions (alphabetically)
!
!     integer i
!        loop index.
!     integer itemp(10)
!        a temporary vector of integer storage.
!     integer n
!        input parameter.  the length of the original data vector.
!     integer nnzw
!        input parameter.  the number of values in the original data
!        vector with weights greater than 0.0e0.
!     real sts(53)
!        input parameter.  the vector of 53 statistics computed.
!        row statistic                    row statistic
!         1  length of vector             tests for nonrandomness
!         2  number of nonzero weights    23  number of runs up and down
!        measures of location             24  expected number of runs
!         3  unweighted mean              25  s.d. of number of runs
!         4  weighted mean                26  mean sqr. successive diff.
!         5  median                       27  mean sqr. succ. diff./var.
!         6  mid-range                    deviations from wtd mean
!         7  25 p.c. unwtd. trimmed mean  28  number of + signs
!         8  25 p.c. wtd. trimmed mean    29  number of - signs
!        measures of dispersion           30  number of runs
!         9  standard deviation (s.d.)    31  expected number of runs
!        10  s.d. of mean                 32  s.d. of runs
!        11  range                        33  diff./s.d. of runs
!        12  mean variation               other statistics
!        13  variance (var.)              34  minimum
!        14  coefficient of variation     35  maximum
!        confidence intervals             36  beta 1
!        15  lower confidence limit, mean 37  beta 2
!        16  upper confidence limit, mean 38  wtd. sum of values
!        17  lower confidence limit, s.d. 39  wtd. sum of squares
!        18  upper confidence limit, s.d. 40  wtd. sum of sqrd. devs.
!        linear trend statistics          41  students t
!        19  slope                        42  wtd. sum of abs. values
!        20  s.d. of slope                43  wtd. avg. abs. values
!        21  slope/s.d. of slope = t      44-53 freq. distribution
!        22  prob ( x > abs(obs. t))
!     logical wts
!        input parameter.  a flag to indicate whether or not there are
!        weights.
!

!
!  print heading
!
  call versp(.true.)
!
!  print numbers of observations, raw and nonzero weighted.
!
  if (.not.wts) write ( *,1000)
  if (wts) write ( *,1010)

  if ( nnzw == n ) then
    write ( *,1020) nnzw
  else
    write ( *,1030) nnzw, n
    write ( *,1040)
  end if
!
!  print frequency distributions
!
  do i=1,10
    itemp(i) = int ( sts(i+43) )
  end do

  write ( *,1050) (itemp(i),i=1,10)
!
!  print measures of location and dispersion
!
  write ( *,1060)
  if (sts(4) /= 0.0e0) then
     write ( *,1070) (sts(i+2),sts(i+8),i=1,6)
  else
     write ( *,1080) (sts(i+2),sts(i+8),i=1,5), sts(8)
  end if
!
!  print confidence intervals
!
  write ( *,1090) sts(15:18)
!
!  print linear trend and other statistics, and print heading for
!  tests for nonrandomness
!
  write ( *,1100) &
     (sts(i),sts(i+15),i=19,22), sts(38:41)

  itemp(1) = int ( sts(23) )
  itemp(2) = int ( sts(28) )
  itemp(3) = int ( sts(29) )
  itemp(4) = int ( sts(30) )
!
!  print tests for nonrandomness
!
  write ( *,1110) itemp(1), sts(42), sts(24), sts(43), &
     (sts(i),i=25,27), (itemp(i),i=2,4), sts(31:33)
!
!  print footnote
!
  write ( *,1120)
  return

 1000 format('+statistical analysis')
 1010 format('+weighted statistical analysis')
 1020 format(//5x, 'n = ', i5)
 1030 format(//5x, 'n = ', i5, ' (no. of non-zero wts)    length', &
     ' =', i5)
 1040 format(/5x, 'all computations are based on observations wi', &
     'th non-zero weights')
 1050 format(//5x, 'frequency distribution (1-6)', 7x, 10i6)
 1060 format(//5x, 'measures of location (2-2)', 34x, 'measures o', &
     'f dispersion (2-6)')
 1070 format(/10x, 'unweighted mean          =', 1pe15.7, 20x, &
     'wtd standard deviation   =', e15.7/10x, 'weighted mean    ', &
     '        =', e15.7, 20x, 'weighted s.d. of mean    =', &
     e15.7/10x, 'median                   =', e15.7, 20x, 'range ', &
     '                   =', e15.7/10x, 'mid-range              ', &
     '  =', e15.7, 20x, 'mean deviation           =', e15.7/10x, &
     '25 pct unwtd trimmed mean=', e15.7, 20x, 'variance        ', &
     '         =', e15.7/10x, '25 pct wtd trimmed mean  =', &
     e15.7, 20x, 'coef. of. var. (percent) =', e15.7)
 1080 format(/10x, 'unweighted mean          =', 1pe15.7, 20x, &
     'wtd standard deviation   =', e15.7/10x, 'weighted mean    ', &
     '        =', e15.7, 20x, 'weighted s.d. of mean    =', &
     e15.7/10x, 'median                   =', e15.7, 20x, 'range ', &
     '                   =', e15.7/10x, 'mid-range              ', &
     '  =', e15.7, 20x, 'mean deviation           =', e15.7/10x, &
     '25 pct unwtd trimmed mean=', e15.7, 20x, 'variance        ', &
     '         =', e15.7/10x, '25 pct wtd trimmed mean  =', &
     e15.7, 20x, 'coefficient of variation =', '    undefined'/ &
     98x, '(mean is zero)')
 1090 format(///20x, 'a two-sided 95 pct confidence interval for mea', &
     'n is', 1pe14.7, ' to ', e14.7, ' (2-2)'/20x, 'a two-sided 9', &
     '5 pct confidence interval for s.d. is', e14.7, ' to ', &
     e14.7, ' (2-7)')
 1100 format(///5x, 'linear trend statistics (5-1) ', 30x, 'other ', &
     'statistics'//10x, 'slope', 20x, '=', 1pe15.7, 20x, 'minimum', &
     18x, '=', e15.7/10x, 's.d. of slope', 12x, '=', e15.7, 20x, &
     'maximum', 18x, '=', e15.7/10x, 'slope/s.d. of slope = t  =', &
     e15.7, 20x, 'beta one', 17x, '=', e15.7/10x, 'prob exceeding', &
     ' abs value of obs t =', 0pf6.3, 20x, 'beta two', 17x, '=', &
   1pe15.7/71x, 'wtd sum of values', 8x, '=', e15.7/71x, 'wtd sum', &
     ' of squares', 7x, '=', e15.7/5x, 'tests for non-randomness', &
     42x, 'wtd sum of dev squared', '   =', e15.7/71x, 'students ', &
     't', 15x, '=', e15.7)
 1110 format(10x, 'hno. of runs up and down  =', i5, 30x, 'wtd sum a', &
     'bsolute values  =', 1pe15.7/ &
     10x, 'expected no. of runs     =', &
     0pf7.1, 28x, 'wtd ave absolute values  =', 1pe15.7/ &
     10x, 's.d. of no. of runs      =', 0pf8.2/ &
     10x, 'mean sq successive diff  =', 1x, 1pe16.7/ &
     10x, 'mean sq succ diff/var    =', 0pf9.3/// &
     10x, 'deviations from wtd mean'// &
     15x, 'no. of + signs      =', i5/ &
     15x, 'no. of - signs      =', i5/ &
     15x, 'no. of runs         =', i5/ &
     15x, 'expected no. of runs=', f7.1/ &
     15x, 's.d. of runs', 8x, '=', f8.2/ &
     15x, 'diff./s.d. of runs  =', f9.3)
 1120 format(///' note - items in parentheses refer to page number', &
     ' in nbs handbook 91 (natrella, 1966)')
end
subroutine sumss ( x, n, lo, mid, hi, sum1, sum2, suma, xmean )

!*****************************************************************************80
!
!! SUMSS calculates the sum of powers and mean for a sorted vector.
!
!  Discussion:
!
!    a routine to calculate sums of powers and the mean
!    for a sorted vector in which the midth element is
!    the element closest to zero.  used by the stat
!    family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sum1,sum2,suma,xmean
  integer &
     hi,lo,mid,n
!
!  array arguments
  real &
     x(n)

  integer &
     curhi,curlo,i,irev
!
!     variable definitions (alphabetically)
!
!     integer curhi
!        the upper bound of the current interval.
!     integer curlo
!        the lower bound of the current interval.
!     integer hi
!        input parameter.  the upper bound of the initial
!        interval.
!     integer i
!        loop parameter.
!     integer irev
!        a variable which runs in the same interval as i, but
!        in the reverse order.
!     integer lo
!        input parameter.  the lower bound of the initial interval.
!     integer mid
!        input parameter.  the index of the element in x closest to
!        zero in value.  the point out from which the summing is
!        done.
!     integer n
!        input parameter.  the length of the array x.
!     real suma
!        output parameter.  the sum of the absolute values of the
!        elements of x.
!     real sum1
!        output parameter.  the sum of the elements of x.
!     real sum2
!        output parameter.  the sum of the squares of the
!        elements of x.
!     real x(n)
!        input parameter.  the data array x over which the sums are
!        taken.
!     real xmean
!        output parameter.  the unweighted mean of x.
!
  sum1 = x(mid)
  sum2 = x(mid)*x(mid)
  suma = abs(x(mid))
  curlo = mid - 1
  curhi = mid + 1
!
!  sum outwards from the value nearest zero.  that is, sum from
!  the least in magnitude to the greatest.
!
  do

    if (curhi > hi .or. curlo<lo) then
      exit
    end if

    if (abs(x(curhi))<abs(x(curlo))) then
      sum1 = sum1 + x(curhi)
      sum2 = sum2 + x(curhi)*x(curhi)
      suma = suma + abs(x(curhi))
      curhi = curhi + 1
    else
      sum1 = sum1 + x(curlo)
      sum2 = sum2 + x(curlo)*x(curlo)
      suma = suma + abs(x(curlo))
      curlo = curlo - 1
    end if

  end do
!
!  sum up any values which may remain because of an off
!  center zero point.
!
  do i=curhi,hi
     sum1 = sum1 + x(i)
     sum2 = sum2 + x(i)*x(i)
     suma = suma + abs(x(i))
  end do

  if ( lo <= curlo ) then
    do irev=lo,curlo
      i = lo - irev + curlo
      sum1 = sum1 + x(i)
      sum2 = sum2 + x(i)*x(i)
      suma = suma + abs(x(i))
     end do
  end if

  xmean = sum1 / real ( hi - lo + 1 )

  return
end
subroutine sumts ( x, n, alpha, sumt1, xtrm )

!*****************************************************************************80
!
!! SUMTS calculates the unweighted trimmed mean for a sorted vector.
!
!  Discussion:
!
!    a routine to calculate the unweighted trimmed mean for
!    a sorted vector in which the midth element is the element
!    closest to zero.  used by the stat family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     alpha,sumt1,xtrm
  integer &
     n
!
!  array arguments
  real &
     x(n)

  integer &
     curhi,curlo,i,irev,ithi,itlo,mid,nalpha
!
!  external subroutines
  external sumbs
!
!     variable definitions (alphabetically)
!
!     real alpha
!        input parameter.  the percentage of points to trim
!        from each end of the array x for the trimmed mean.
!     integer curhi
!        the upper bound of the current interval.
!     integer curlo
!        the lower bound of the current interval.
!     integer irev
!        a variable which runs in the same interval as i, but
!        in the reverse order.
!     integer ithi
!        the computed upper bound such that alpha per
!        cent of the positively weighted points are
!        omitted.
!     integer itlo
!        the computed lower bound such that alpha per
!        cent of the positively weighted points are
!        omitted.
!     integer mid
!        the index of the element in x closest to zero in value.
!        the point out from which the summing is done.
!     integer n
!        input parameter.  the length of the array x.
!     integer nalpha
!        the integer which is alpha per cent of n.
!     real sumt1
!        output parameter.  the unweighted sum of the trimmed
!        array.  zero-weighted elements are omitted.
!     real x(n)
!        input parameter.  the data array x in which the sums are taken.
!     real xtrm
!        output parameter.  the unweighted, trimmed mean of x.
!
!  set up limits trimming the number of values at each end
!  by alpha per cent.
!
  nalpha = int ( alpha * real ( n ) )
  itlo = nalpha + 1
  ithi = n - nalpha
  call sumbs(x, n, itlo, mid, ithi)
!
!  initialize summation variables.
!
  sumt1 = x(mid)
  curlo = mid - 1
  curhi = mid + 1
!
!  sum outwards from the value nearest zero.  that is, sum from
!  the least in magnitude to the greatest.
!
  do

    if (curhi > ithi .or. curlo<itlo) then
      exit
    end if

    if (abs(x(curhi))<abs(x(curlo))) then
      sumt1 = sumt1 + x(curhi)
      curhi = curhi + 1
    else
      sumt1 = sumt1 + x(curlo)
      curlo = curlo - 1
    end if

  end do
!
!  sum up any values which may remain because of an off
!  center zero point.
!
  if ( curhi <= ithi ) then
    curhi = max(curhi,itlo)
    do i=curhi,ithi
      sumt1 = sumt1 + x(i)
    end do
  end if

  if ( itlo <= curlo ) then
    curlo = min(curlo,ithi)
    do irev=itlo,curlo
      i = itlo - irev + curlo
      sumt1 = sumt1 + x(i)
    end do
  end if

  xtrm = sumt1 / real ( n - 2 * nalpha )

  return
end
subroutine sumwds ( x, w, n, lo, mid, hi, xmeanw, sumda, sumwd2, &
     sumd2, sumd3, sumd4 )

!*****************************************************************************80
!
!! SUMWDS calculates sums of powers of differences from the weighted mean.
!
!  Discussion:
!
!    a routine to calculate weighted and unweighted sums
!    of powers of differences from the weighted mean for a
!    sorted vector in which the midth element is the element
!    closest to zero.  used by the stat family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     sumd2,sumd3,sumd4,sumda,sumwd2,xmeanw
  integer &
     hi,lo,mid,n
!
!  array arguments
  real &
     w(n),x(n)
!
!
  real &
     diff
  integer &
     curhi,curlo,i,irev
!
!     variable definitions (alphabetically)
!
!     integer curhi
!        the upper bound of the current interval.
!     integer curlo
!        the lower bound of the current interval.
!     real diff
!        the differences between x(i) and xmeanw.
!     integer hi
!        input parameter.  the upper bound of the initial
!        interval.
!     integer irev
!        a variable which runs in the same interval as i, but
!        in the reverse order.
!     integer lo
!        input parameter.  the lower bound of the initial
!        interval.
!     integer mid
!        input parameter.  the index of the element in x closest to
!        zero in value.  the point out from which the summing is
!        done.
!     integer n
!        input parameter.  the length of the array x.
!     real sumda
!        output parameter.  the sum of the absolute values of the
!        differences diff.
!     real sumd2
!        output parameter.  the sum of the squares of the
!        differences diff.
!     real sumd3
!        output parameter.  the sum of the cubes of the
!        differences diff.
!     real sumd4
!        output parameter.  the sum of the hypercubes of the
!        differences diff.
!     real sumwd2
!        output parameter.  the weighted sum of the squares of
!        the differences diff.
!     real w(n)
!        input parameter.  the array of weights.
!     real x(n)
!        input parameter.  the data array x in which the sums are taken.
!     real xmeanw
!        input parameter.  the weighted mean of x.
!
  sumda = 0.0e0
  sumwd2 = 0.0e0
  sumd2 = 0.0e0
  sumd3 = 0.0e0
  sumd4 = 0.0e0

  if ( w(mid) /= 0.0e0 ) then
    diff = x(mid) - xmeanw
    sumda = abs(diff)
    sumwd2 = w(mid)*diff*diff
    sumd2 = diff*diff
    sumd3 = diff*diff*diff
    sumd4 = diff*diff*diff*diff
  end if

  curlo = mid - 1
  curhi = mid + 1
!
!  sum outwards, boulder, colorado from the value nearest zero.  that
!  the least in magnitude to the greatest.
!
  do

    if (curhi > hi .or. curlo<lo) then
      exit
    end if

    if (abs(x(curhi))<abs(x(curlo))) then

      if ( w(curhi) /= 0.0e0) then
        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
      end if

      curhi = curhi + 1

    else

      if ( w(curlo) /= 0.0e0) then
        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
      end if

      curlo = curlo - 1

    end if

  end do
!
!  sum up any values which may remain because of an off-center zero point.
!
  do i=curhi,hi

    if ( w(i) == 0.0e0 ) then
      cycle
    end if

    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

  end do

  do irev=lo,curlo

    i = lo - irev + curlo
    if ( w(i) == 0.0e0 ) then
      cycle
    end if

    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

  end do

  return
end
subroutine sumwss ( x, w, n, lo, mid, hi, nnzw, sum1, sumw1, sumw2, &
     sumwa, sumw, xmean, xmeanw )

!*****************************************************************************80
!
!! SUMWSS calculates weighted and unweighted sums of powers and the mean.
!
!  Discussion:
!
!    a routine to calculate weighted and unweighted sums of
!    powers and the mean for a sorted vector in which the mid th
!    element is the element closest to zero.  used by the stat
!    family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer n

  integer hi
  integer lo
  integer mid
  integer nnzw
  real sum1
  real sumw
  real sumw1
  real sumw2
  real sumwa
  real w(n)
  real x(n)
  real xmean
  real xmeanw

  integer &
     curhi,curlo,i,irev
!
!     variable definitions (alphabetically)
!
!     integer curhi
!        the upper bound of the current interval.
!     integer curlo
!        the lower bound of the current interval.
!     integer hi
!        input parameter.  the upper bound of the initial
!        interval.
!     integer i
!        loop parameter.
!     integer irev
!        a variable which runs in the same interval as i, but
!        in the reverse order.
!     integer lo
!        input parameter.  the lower bound of the initial
!        interval.
!     integer mid
!        input parameter.  the index of the element in x closest to
!        zero in value.  the point out from which the summing is
!        done.
!     integer n
!        input parameter.  the length of the array x.
!     integer nnzw
!        input parameter.  the number of positively weighted values
!        in x.
!     real sumw
!        output parameter.  the sum of the weights wt(i).
!     real sumwa
!        output parameter.  the weighted sum of the absolute
!        values of the elements of x.
!     real sumw1
!        output parameter.  the weighted sum of the elements of
!        x.
!     real sumw2
!        output parameter.  the weighted sum of the squares of
!        the elements of x.
!     real sum1
!        output parameter.  the unweighted sum of the elements of x.
!     real w(n)
!        input parameter.  the array of weights.
!     real x(n)
!        input parameter.  the data array x in which the sums are taken.
!     real xmean
!        output parameter.  the unweighted mean of x.
!     real xmeanw
!        output parameter.  the weighted mean of x.
!
  sum1 = 0.0e0
  sumw1 = 0.0e0
  sumw2 = 0.0e0
  sumwa = 0.0e0
  sumw = 0.0e0

  if ( w(mid) /= 0.0e0 ) then
    sum1 = x(mid)
    sumw1 = w(mid)*x(mid)
    sumw2 = w(mid)*x(mid)*x(mid)
    sumwa = w(mid)*abs(x(mid))
    sumw = w(mid)
  end if

  curlo = mid - 1
  curhi = mid + 1
!
!  sum outwards, from the value nearest zero.  that is, from
!  the least in magnitude to the greatest.
!
   20 if (curhi > hi .or. curlo<lo) go to 60

  if (abs(x(curhi))<abs(x(curlo))) go to 40
  if (w(curlo) == 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) == 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
!
!  sum up any values which may remain because of an off
!  center zero point.
!
   60 continue

  do i=curhi,hi

    if ( w(i) == 0.0e0) then
      cycle
    end if

    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)

  end do

  do irev=lo, curlo

    i = lo - irev + curlo

    if ( w(i) == 0.0e0 ) then
      cycle
    end if

     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)

  end do

  xmean = sum1 / real ( nnzw )
  xmeanw = sumw1 / real ( sumw )

  return
end
subroutine sumwts ( x, w, n, nnzw, alpha, sumt1, sumtw1, xtrm, xtrmw )

!*****************************************************************************80
!
!! SUMWTS calculates weighted and unweighted means for a sorted vector.
!
!  Discussion:
!
!    a routine to calculate the weighted and unweighted means
!    for a sorted vector in which the midth element is the
!    element closest to zero.  used by the stat family.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer n

  integer nnzw
  real alpha
  real sumt1
  real sumtw1
  real w(n)
  real x(n)
  real xtrm
  real xtrmw

  real &
     sumw
  integer &
     curhi,curlo,i,irev,ithi,itlo,mid,nalpha,num
!
!  external subroutines
  external sumbs
!
!     variable definitions (alphabetically)
!
!     real alpha
!        input parameter.  the percentage of points to trim
!        from each end of the array x for the trimmed mean.
!     integer curhi
!        the upper bound of the current interval.
!     integer curlo
!        the lower bound of the current interval.
!     integer i
!        loop parameter.
!     integer irev
!        a variable which runs in the same interval as i, but
!        in the reverse order.
!     integer ithi
!        the computed upper bound such that alpha per
!        cent of the positively weighted points are
!        omitted.
!     integer itlo
!        the computed lower bound such that alpha per
!        cent of the positively weighted points are
!        omitted.
!     integer mid
!        the index of the element in x closest to zero in value.
!        the point out from which the summing is done.
!     integer n
!        input parameter.  the length of the array x.
!     integer nalpha
!          the integer which is alpha per cent of n.
!     integer nnzw
!        input parameter.  the number of positively weighted
!        values in x.
!     integer num
!        the number of points omitted so far.
!     real sumtw1
!        output parameter.  the weighted sum of the trimmed array
!        x.
!     real sumt1
!        output parameter.  the unweighted sum of the trimmed
!        array.  zero-weighted elements are omitted.
!     real sumw
!        the sum of the weights w(i).
!     real w(n)
!        input parameter.  the array of weights.
!     real x(n)
!        input parameter.  the data array x in which the sums are taken.
!     real xtrm
!        output parameter.  the unweighted, trimmed mean of x.
!     real xtrmw
!        output parameter.  the weighted, trimmed mean of x.
!
!  set up limits trimming the number of non-zero weighted
!  values by alpha per cent at each end of the range of
!  values.
!
  nalpha = int ( alpha * real ( nnzw ) )
  num = 0
  do i=1,n
    if (w(i) /= 0.0e0) then
      num = num + 1
      if (num == nalpha+1) then
        exit
      end if
    end if
  end do

  itlo = i
  num = 0
  do i=1,n
     irev = n - i + 1
     if ( w(irev) /= 0.0e0 ) then
       num = num + 1
       if (num == nalpha+1) then
         exit
       end if
     end if

  end do

  ithi = irev
  call sumbs(x, n, itlo, mid, ithi)

  if ( w(mid) == 0.0 ) then
    sumt1 = 0.0e0
    sumtw1 = 0.0e0
    sumw = 0.0e0
  else
    sumt1 = x(mid)
    sumtw1 = w(mid)*x(mid)
    sumw = w(mid)
  end if

  curlo = mid - 1
  curhi = mid + 1
!
!  sum outwards, boulder, colorado from the value nearest zero.  that
!  the least in magnitude to the greatest.
!
   60 continue

  if (curhi > ithi .or. curlo<itlo) go to 100
  if (abs(x(curhi))<abs(x(curlo))) go to 80
  if (w(curlo) == 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 continue

  if ( w(curhi) /= 0.0e0 ) then
    sumt1 = sumt1 + x(curhi)
    sumtw1 = sumtw1 + w(curhi)*x(curhi)
    sumw = sumw + w(curhi)
  end if

  curhi = curhi + 1
  go to 60
!
!  sum up any values which may remain because of an off
!  center zero point.
!
  100 continue

  if ( curhi <= ithi ) then

    curhi = max(curhi,itlo)

    do i=curhi,ithi
      if (w(i) /= 0.0e0) then
        sumt1 = sumt1 + x(i)
        sumtw1 = sumtw1 + w(i)*x(i)
        sumw = sumw + w(i)
      end if
    end do

  end if

  if ( itlo <= curlo ) then

    curlo = min(curlo,ithi)

    do irev=itlo,curlo
      i = itlo - irev + curlo
      if (w(i) /= 0.0e0) then
        sumt1 = sumt1 + x(i)
        sumtw1 = sumtw1 + w(i)*x(i)
        sumw = sumw + w(i)
      end if
    end do

  end if

  xtrm = sumt1/ real ( nnzw - 2 * nalpha )
  xtrmw = sumtw1/sumw

  return
end
subroutine svpc ( ym, n, ns, isym, ilog, isize, irlin, ibar, &
     ylb, yub, xlb, xinc )

!*****************************************************************************80
!
!! SVPC produces a vertical plot with user plot symbols (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,isize,n,ns
!
!  array arguments
  real &
     ym(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr
!
!
  integer ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real yub
!        upper bound for y-axis.
!
!  set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'v',       'p',       'c',       ' ',       ' '/

  m = 1
  iym = n
  multi = .false.
  ischck = 1
  miss = .false.
  lisym = n

  call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call svpc (y, n, ns, isym, ilog,'/ &
    '      +           isize, irlin, ibar, ylb, yub, xlb, xinc)')
end
subroutine svp ( ym, n, ns, isym )

!*****************************************************************************80
!
!! SVP: vertical plot with user plot symbols (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,ns
!
!  array arguments
  real &
     ym(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real yub
!        upper bound for y-axis.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'v',       'p',       ' ',       ' ',       ' '/

  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

  call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call svp (y, n, ns, isym)')
end
subroutine svpl ( ym, n, ns, isym, ilog )

!*****************************************************************************80
!
!! SVPL produces a vertical log plot with user control of the plot symbol.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ilog,n,ns
!
!  array arguments
  real &
     ym(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real yub
!        upper bound for y-axis.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'v',       'p',       'l',       ' ',       ' '/

  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

  call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call svpl (y, n, ns, isym, ilog)')
end
subroutine svpmc ( ym, ymmiss, n, ns, isym, ilog, isize, &
     irlin, ibar, ylb, yub, xlb, xinc )

!*****************************************************************************80
!
!! SVPMC: vertical plot with missing data and user plot symbols (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,isize,n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr

  integer ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'v',       'p',       'm',       'c',       ' '/

  m = 1
  iym = n
  multi = .false.
  ischck = 1
  miss = .true.
  lisym = n

  call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call svpmc (y, ymiss, n, ns, isym, ilog,'/ &
    '      +            isize, irlin, ibar, ylb, yub, xlb, xinc)')
end
subroutine svpm ( ym, ymmiss, n, ns, isym )

!*****************************************************************************80
!
!! SVPM: vertical plot with missing data and user plot symbols (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'v',       'p',       'm',       ' ',       ' '/

  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

  call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call svpm (y, ymiss, n, ns, isym)')
end
subroutine svpml ( ym, ymmiss, n, ns, isym, ilog )

!*****************************************************************************80
!
!! SVPML: vertical plot with missing data, user plot symbols (log plot option).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ilog,n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(*)
  integer &
     isym(*)
!
!  scalars in common
  integer &
     ierr

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(n)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  's',       'v',       'p',       'm',       'l',       ' '/

  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

  call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if
  return

 1000 format (/' the correct form of the call statement is'// &
    '       call svpml (y, ymiss, n, ns, isym, ilog)')
end
subroutine taper ( y, n, taperp, yt )

!*****************************************************************************80
!
!! TAPER applies a split-cosine-bell taper to a centered observed series.
!
!  Discussion:
!
!    this is the user routine for applying a split-cosine-bell
!    taper to the (centered) observed series y, returning the tapered
!    series in yt.  this routine is adapted from bloomfields
!    routine taper.
!
!  Modified:
!
!    30 April 2006
!
!  Author:
!
!    Peter Bloomfield
!
!    Adapted by Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Reference:
!
!    Peter Bloomfield,
!    Fourier Analysis of Time Series - An Introduction,
!    Wiley, New York, 1976.
!
  implicit none

  real &
     taperp
  integer &
     n
!
!  array arguments
  real &
     y(*),yt(*)
!
!  scalars in common
  integer &
     ierr

  real &
     pi,weight
  integer &
     i,j,m
  logical &
     err01,head
!
!  local arrays
  character &
     ln(8)*1,nmsub(6)*1
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err01
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a variable used to indicare whether a heading is needed for
!        error messages (true) or not (false).
!     integer i
!        an indexing variable.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list.
!        if ierr == 0, no errors were detected.
!        if ierr == 1, errors have been detected.
!     integer j
!        an indexing variable.
!     character*1 ln(8)
!        the array(s) containing the name(s) of the parameter(s) checked
!        for errors.
!     integer m
!        the number of points at each end of the series to be
!        tapered.
!     integer n
!        the number of observations in the series y.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     real pi
!        the value of pi.
!     real taperp
!        the total percentage of the data to be tapered.
!     real weight
!        the ith taper weight.
!     real y(n)
!        the vector containing the observed time series.
!     real yt(n)
!        the vector in which the tapered series is returned.
!
!     set up name arrays
!
  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',' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.

  call eisge(nmsub, ln, n, 17, 1, head, err01, ln)

  if ( err01 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if

  call center (y, n, yt)

  if ((taperp <= 0.0e0) .or. (taperp > 1.0e0)) return

  call getpi(pi)

  m = int ( taperp * real ( n ) + 0.5e0 ) / 2

  do i = 1, m
     weight = 0.5e0 - 0.5e0 * cos(pi * (real ( i ) -0.5e0) / real ( m ) )
     yt(i) = weight * yt(i)
     j = n + 1 - i
     yt(j) = weight * yt(j)
  end do

  return
 1000 format (/' the correct form of the call statement is'// &
     '       call taper (y, n, taperp, yt)')
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end
subroutine uas ( y, n )

!*****************************************************************************80
!
!! UAS is the user callable routine for autoregressive spectrum estimation.
!
!  Discussion:
!
!    This is the short call version.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     alpha,delta,fmax,fmin,var,ymean
  integer &
     iar,lacov,lag,lagmax,laic,ldsmin,ldstak,lpcv,lphi, &
     lspc,lwork,nf,nprt
!
!  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
!
!  external subroutines
  external acvf,parzen,setlag,uasdv,uaser
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real acov(101)
!        the autocovariance computed from the lag product pairs.
!     real aic(101)
!        the array contaning akiakes criteria for each order.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequency for which the
!        spectrum estimates are to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     real ftest(2, 100)
!        the array in which the f ratio and probability are stored.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected
!     integer isort(101)
!        an array used for sorting.
!     integer isym(207)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the covariance arrays.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the array aic.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lphi
!        the length of the vector phi.
!     integer lspc
!         the length of the spectrum arrays.
!     integer lwork
!        the length of the vector work.
!     integer n
!        the integer number of observations in the series.
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the type of window to be used.
!     real phi(100)
!        the array of autoregressive coefficients for the
!        selected order.
!     real spca(101)
!        the aray containing the autoregressive spectrum estimates.
!     real spcf(101)
!        the array containing the Fourier spectrum estimates.
!     real var
!        the one step prediction variance for the selected model.
!     real work(101)
!        a real work area used for the lag windows and for
!        computing the autoregressive coefficients.
!     real xaxis(207)
!        the x axis values for the spectrum plot.
!     real y(n)
!        the array containing the observed time series.
!     real yaxis(207)
!        the y axis values for the spectrum plot.
!     real ymean
!        the mean of the observed time series
!
!  set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'u',       'a',       's',       ' ',       ' ',       ' '/

  option(1) = .false.
  option(2) = .false.
  option(3) = .false.
  option(4) = .false.

  lag = 0
  iar = 0
  nf = 101
  fmin = 0.0e0
  fmax = 0.5e0
  nprt = -1
  ldstak = 0
  ldsmin = 0
!
!  set the maximum number of lags to be used.
!
  call setlag(n, lagmax)
!
!  call error checking routine
!
  call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, &
     nf, ldstak, ldsmin, n, n, option)

  if (ierr /= 0) then
     ierr = 1
     write ( *, 1000)
     return
  end if

  lpcv = 207
  lspc = 101
  lphi = 100
  laic = 101
  lacov = 101
  lwork = 101

  alpha = .95e0
  delta = 1.0e0
!
!  compute autocovariances
!
  call acvf ( y, n, ymean, acov, lagmax, lacov )
!
!  call the main driver for autoregressive spectrum routines.
!
  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 )

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call uas (y, n)')
end
subroutine uascft ( acov, lagmax, lacov, iar, phi, n, var )

!*****************************************************************************80
!
!! UASCFT computes autoregressive coefficients using Durbin's method.
!
!  Discussion:
!
!    this routine computes the autoregressive model coefficients
!    for an order iar model using durbins recursive method.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the array of autocovariance estimates.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer l
!        an index variable.
!     integer lacov
!        the length of the array acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer n
!        the number of observations in the series.
!     real phi(iar)
!        the array of autoregressive coefficients for the
!        selected order.
!     real rss, var
!
  implicit none

  integer iar
  integer lacov

  real acov(lacov)
  integer l
  integer lagmax
  integer n
  real phi(iar)
  real rss
  real var

  phi(1) = acov(2) / acov(1)
  rss = acov(1) * real ( n ) * (1.0e0 - phi(1)*phi(1))

  do l = 2, iar
    call arcoef(acov(2), phi, rss, l, lagmax, acov(1))
  end do

  var = rss / real ( n - iar - 1 )

  return
end
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 )

!*****************************************************************************80
!
!! UASDV is the driver for computing the autoregressive and Fourier spectrums.
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance computed from the lag product pairs.
!     real aic(laic)
!        the array containing the akaikes criteria for each order(?).
!     logical aicprt
!        an indicator variable used to determine if the akiake
!        information criteria and chi squared statistics should
!        be printed.
!     real alow
!        a factor used to compute the lower confidence limits.
!     real alpha
!        the desired confidence level.
!     real aup
!        a factor used to compute the upper confidence limits.
!     real bw
!        the bandwidth.
!     real delta
!        the sampling interval.
!     real df
!        the effective degrees of freedom.
!     real fmax, fmin
!        the maximum and minimum frequency for which the
!        spectrum estimates are to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     real ftest(2,lagmax)
!        the array in which the f ratio and probability are stored.
!        the order of the autoregressive process chosen.
!     integer isort(nf)
!        an array used for sorting.
!     integer lspc
!         the actual first dimension for the spectrum arrays.
!     integer ispcer
!        an error flag used for the spectrum plots.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the covariance arrays.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(1)
!        the lag window truncation point returned from ufslag.
!     integer laic
!        the length of the array aic.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lphi
!        the length of the vector phi.
!     integer lwork
!        the actual length of the work array.
!     integer n
!        the integer number of observations in the series
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     integer nlppa(1)
!        a dummy array
!     character*1 nmsub(6)
!        the name of the calling subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer npts
!        the number of x, y coordinates to be plotted.
!     integer nspca, nspcf
!        the number of valid spectrum estimates for the autoregressive
!        and Fourier spectrums, respectively.
!     integer nw
!        the number of lag window truncation points selcted.
!     real phi(lphi)
!        the array of autoregressive coefficients for the
!        selected order.
!     real spca(lspc)
!        the aray containing the autoregressive spectrum estimates.
!     real spcamn, spcamx
!        the minimum and maximum autoregressive spectrum value to be
!        plotted.
!     real spcf(lspc)
!        the array containing the Fourier spectrum estimates.
!     real spcfmn, spcfmx
!        the minimum and maximum Fourier spectrum value to be plotted.
!     real var
!        the one step prediction variance.
!     external window
!        the type of window to be used.
!     real work(lwork)
!        the work array.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plot.
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plot.
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
  implicit none

  real alpha
  real delta
  real fmax
  real fmin
  integer iar
  integer lacov
  integer lag
  integer lagmax
  integer laic
  integer lpcv
  integer lphi
  integer lspc
  integer lwork
  integer n
  integer nf
  integer nprt
  real var
!
!  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
!
!  subroutine arguments
  external window
!
!
  real &
     alow,aup,bw,df,spcamn,spcamx,spcfmn,spcfmx,xpltmn,xpltmx, &
     ypltmn,ypltmx
  integer &
     ispcer,npts,nspca,nspcf,nw
  logical &
     aicprt
!
!  local arrays
  integer &
     lags(1),nlppa(1)
!
!  external subroutines
  external aos,setfrq,spcck,uascft,uasest,uasord,uasout,ufslag,ufsmn

  nw = 1
!
!  Set the lag window truncation point to be used for the
!  Fourier spectrum estimates.
!
  if ( lag <= 0 ) then
    call ufslag ( acov, lagmax, lags, n, nw, nw, lacov )
    lag = lags(1)/2
  end if
!
!  Set frequencies for the spectrum.
!
  call setfrq ( freq, nf, 1, fmin, fmax, delta )
!
!  Compute the Fourier spectrum estimates
!
  call ufsmn ( acov, nlppa, lag, df, nf, freq, alpha, bw, spcf, &
    alow, aup, lacov, lspc, window, work, lwork, n, delta, &
    .false., 1 )

  aicprt = .false.
!
!  User has chosen order.
!  Compute coefficients and variance using durbins recursive method.
!
  if ( iar < 0 ) then

    call uascft ( acov, lagmax, lacov, iabs(iar), phi, n, var )
!
!  Select model order and compute coefficients and variance.
!
  else if ( iar == 0 ) then

   aicprt = .true.
   call aos ( n, lagmax, acov, work, iar, var, phi, &
              work, aic, ftest, lacov, laic )
  end if
!
!  Compute the autoregressive spectrum estimates.
!
  call uasest ( iabs(iar), var, phi, nf, freq, delta, spca, lphi, &
     lspc )

  if ( nprt == 0 ) then
    return
  end if
!
!  Set plotting vectors.
!
  xpltmn = fmin
  xpltmx = fmax

  ypltmn = 0.0e0
  ypltmx = 0.0e0

  call spcck ( spcf, isort, nf, spcfmn, spcfmx, nspcf, ispcer )

  if ( ispcer == 0 ) then

    call spcck ( spca, isort, nf, spcamn, spcamx, nspca, ispcer )

    if ( ispcer == 0 ) then

      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 )

    end if

  end if
!
!  print results
!
  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 )

  return
end
subroutine uaser ( nmsub, n, acov, iar, phi, lagmax, lag, lacov, &
  nf, ldstak, ldsmin, lyfft, nfft, option )

!*****************************************************************************80
!
!! UASER: error checks for time series Fourier univariate spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance function.
!     logical err(20)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     character*1 lacv(8), lacv1p(8),
!    *   liar(8), llacov(8), llag(8), llgmx(8), llgmxm(8),
!    *   llgmxp(8),  llgmx1(8), llds(8), ln(8), lnf(8), lnm1(8),
!    *   llyfft(8), lphi(8), l1(8)
!        the array(s) containing the name(s) of the argument(s)
!        checked for errors.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in the series.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the array containing the name of the user called subroutine.
!     integer nv
!        the number of violations found when checking vector lags.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     real phi(iar)
!        the array of autoregressive coefficients for the
!        selected order.
!
  implicit none

  integer &
     iar,lacov,lag,lagmax,ldsmin,ldstak,lyfft,n,nf,nfft
!
!  array arguments
  real &
     acov(*),phi(*)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr

  integer &
     i,nv
  logical &
     head
!
!  local arrays
  logical &
     err(20)
  character &
     l1(8),lacv(8),liar(8), &
     llacov(8),llag(8),llds(8),llgmx(8),llgmx1(8), &
     llgmxm(8),llgmxp(8),llyfft(8),ln(8),lnf(8), &
     lnm1(8),lphi(8)
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data lacv(1), lacv(2), lacv(3), lacv(4), lacv(5), lacv(6), &
     lacv(7), lacv(8) /'a','c','o','v',' ',' ',' ',' '/

  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', &
     ' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.
  err(1:20) = .false.

  call eisge(nmsub, ln, n, 17, 1, head, err(1), ln)

  if ( option(3) ) then

    call ervii(nmsub, lacv, acov, lagmax+1, -abs(acov(1)), &
      abs(acov(1)), 0, head, 4, nv, err(15) )

    call eisii(nmsub, llgmx, lagmax, 1, n-1, 1, head, err(2), &
      l1, lnm1)

    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

  if (option(1) .and. (.not.err(1))) &
     call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err(4), &
     llyfft)

  if (option(1) .and. (.not.option(4))) &
     call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(5), llds)

  if ( .not. option(4) ) then

    do i = 1, 15
      if (err(i)) then
        ierr = 1
        return
      end if
    end do

    return

  end if

  call eisii(nmsub, liar, iar, -iabs(lagmax), iabs(lagmax), 1, head, &
     err(6), llgmxm, llgmxp)

  call ervii ( nmsub, lphi, phi, iar, -1.0e0, 1.0e0, 0, head, 1, nv, &
     err(7) )

  if (.not.option(3)) then
     call eisii(nmsub, llgmx, lagmax, 1, n-1, 1, head, err(2), &
     l1, lnm1)
  end if

  call eisii(nmsub, llag, lag, -iabs(lagmax), iabs(lagmax), 1, head, &
     err(8), llgmxm, llgmxp)

  call eisge(nmsub, lnf, nf, 1, 1, head, err(9), lnf)

  if (err(1) .or. err(2) .or. err(9)) then
    ierr = 1
    return
  end if

  call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(14), llds)

  do i = 1, 15
     if (err(i)) then
      ierr = 1
      return
    end if
  end do

  return
end
subroutine uasest ( iar, var, phi, nf, freq, delta, spca, lphi, ispc )

!*****************************************************************************80
!
!! UASET calculates the autoregressive spectrum.
!
!  Discussion:
!
!    This routine is modeled after subroutine UASEC by Dick Jones.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta,var
  integer &
     iar,ispc,lphi,nf
!
!  array arguments
  real &
     freq(nf),phi(lphi),spca(ispc)
!
!
  real &
     arg,ei,er,exi,exr,exrtmp,pi,ti,tr
  integer &
     i,j
!
!     variable definitions (alphabetically)
!
!     real arg
!        the argument for the sine and cosine functions used in
!        calculations of the spectrum.
!     real delta
!        the sampling interval.
!     real ei, er, exi, exr, exrtmp
!        'complex' variables used in the computations.
!     real freq(nf)
!        the array containing the frequencies at which the spectrum
!        is to be computed.
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ispc
!        the length of the array spca.
!     integer j
!        an index variable.
!     integer lphi
!        the length of the array phi.
!     integer nf
!        the number of frequencies at which the spectrum is to be
!        estimated.
!     real phi(lphi)
!        the array of autoregressive coefficients for the
!        selected order.
!     real pi
!        the value of pi.
!     real spca(ispc)
!        the array in which the autoregressive spectrum is stored.
!     real ti, tr
!        a variable used in the computations.
!     real var
!        the one step prediction variance for the selected order (iar).
!
  call getpi(pi)

  do j=1,nf

     spca(j) = delta * var
     if (iar >= 1) then
        if (delta == 1.0e0) then
           if (freq(j) == 0.0e0) then
              er = 1.0e0
              ei = 0.0e0
           else if (freq(j) == 0.25e0) then
              er = 0.0e0
              ei = 1.0e0
           else if (freq(j) == 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 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
        end do
        spca(j) = spca(j)/(tr*tr + ti*ti)
     end if

  end do

  return
end
subroutine uasf ( yfft, n, lyfft, ldstak )

!*****************************************************************************80
!
!! UASF is the user callable routine for autoregressive spectrum estimation.
!
!  Discussion:
!
!    This routine uses the fast Fourier transform.  This is the version with
!    a short calling sequence.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ldstak,lyfft,n
!
!  array arguments
  real &
     yfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,fmax,fmin,var,ymean
  integer &
     iar,ifp,lacov,lag,lagmax,laic,ldsmin,lpcv,lphi,lspc, &
     lwork,nall0,nf,nfft,nprt,work
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acvff,ldscmp,parzen,setesl,setlag,stkclr,stkset, &
     uasdv,uaser
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
  equivalence (isym(1),isort(1))
!
!     variable definitions (alphabetically)
!
!     real acov(101)
!        the autocovariance computed from the lag product pairs.
!     real aic(101)
!        the array contaning akiakes criteria for each order.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency for which the
!        spectrum estimates are to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     real ftest(2, 100)
!        the array in which the f ratio and probability are stored.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer isort(101)
!        an array used for sorting.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer lspc
!         the length of the spectrum arrays.
!     integer isym(207)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the covariance arrays.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the array aic.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lphi
!        the length of the vector phi.
!     integer lwork
!        the length of the work array.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of allocations outstanding at the time that
!        this routine was called.
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the type of window to be used.
!     real phi(100)
!        the array of autoregressive coefficients for the
!        selected order.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spca(101)
!        the aray containing the autoregressive spectrum estimates.
!     real spcf(101)
!        the array containing the Fourier spectrum estimates.
!     real var
!        the one step prediction variance.
!     integer work
!        the starting location in rstak for
!        the work vector.
!     real xaxis(207)
!        the x axis values for the spectrum plot.
!     real yaxis(207)
!        the y axis values for the spectrum plot.
!     real yfft(lyfft)
!        the array containing the observed time series.
!     real ymean
!        the mean of the observed time series
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'u',       'a',       's',       'f',       ' ',       ' '/

  ifp = 3

  option(1) = .true.
  option(2) = .false.
  option(3) = .false.
  option(4) = .false.

  lag = 0
  iar = 0
  nf = 101
  fmin = 0.0e0
  fmax = 0.5e0
  nprt = -1
!
!  set the maximum number of lags to be used.
!
  call setlag(n, lagmax)
!
!  set length of extended series
!
  call setesl(n+lagmax, 4, nfft)

  call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin)

  call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, &
     nf, ldstak, ldsmin, lyfft, nfft, option)

  if (ierr /= 0) then
     ierr = 1
     write ( *, 1000)
     return
  end if
!
!  set the size of the work area
!
  call stkset(ldstak, 4)
!
!  save number of outstanding stack allocations.
!
  nall0 = stkst(1)

  lpcv = 207
  lspc = 101
  lphi = 100
  laic = 101
  lacov = 101
  lwork = nfft

  alpha = 0.95e0
  delta = 1.0e0
!
!  subdivide the work area
!
  work = stkget(lwork, ifp)
!
!  compute autocovariances
!
  call acvff (yfft, n, nfft, ymean, acov, lagmax, lacov, lyfft, &
     rstak(work), lwork)
!
!  call the main driver for autoregressive spectrum routines.
!
  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)

  call stkclr(nall0)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call uasf (yfft, n, lyfft, ldstak)')
end
subroutine uasfs ( yfft, n, lyfft, ldstak, iar, phi, lagmax, lag, &
  nf, fmin, fmax, nprt, spca, spcf, freq )

!*****************************************************************************80
!
!! UASFS: interface, autoregressive spectrum estimation using FFT (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin
  integer &
     iar,lag,lagmax,ldstak,lyfft,n,nf,nprt
!
!  array arguments
  real &
     freq(*),phi(*),spca(*),spcf(*),yfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,fmn,fmx,var,ymean
  integer &
     acov,aic,ftest,ia,ifp,io,isort,isym,lacov,laic, &
     ldsmin,lpcv,lphi,lspc,lwork,nall0,nfft,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external acvff,amean,ldscmp,parzen,setesl,stkclr,stkset, &
     uasdv,uaser,uasvar
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     integer acov
!        the starting location in rstak for the array of
!        the autocovariance array.
!     integer aic
!        the starting location in the stack for
!        the array containing the aic.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency for which the
!        spectrum estimates are to be computed.
!     real fmn, fmx
!        the maximum and minimum frequency actually used.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     integer ftest
!        the starting location in the stack for
!        the array in which the f ratio and probability are stored.
!     integer ia
!        a variable used to determine the amount of storage required,
!        based on whether or not the model order is to be selected or
!        has been provided.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer isort
!        the starting location in istak for
!        an array used for sorting.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in istak for
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the covariance arrays.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the array aic.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lphi
!        the length of the vector phi.
!     integer lspc
!         the length of the spectrum arrays.
!     integer lwork
!        the actual length of the work array.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in the series
!     integer nall0
!        the number of stack allocations outstanding when this routine
!        was called.
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the type of window to be used.
!     real phi(lagmax)
!        the array of autoregressive coefficients for the
!        selected order.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spca(nf)
!        the aray containing the autoregressive spectrum estimates.
!     real spcf(nf)
!        the array containing the Fourier spectrum estimates.
!     real var
!        the one step prediction variance.
!     integer work
!        the starting location in the stack for
!        the work array.
!     integer xaxis
!        the starting location in rstak for
!        the x axis values for the spectrum plot.
!     integer yaxis
!        the starting location in rstak for
!        the y axis values for the spectrum plot.
!     real yfft(lyfft)
!        the array containing the observed time series.
!     real ymean
!        the mean of the observed time series
!
!  set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'u',       'a',       's',       'f',       's',       ' '/

  ifp = 3

  option(1) = .true.
  option(2) = .false.
  option(3) = .false.
  option(4) = .true.
!
!  set extended series length
!
  call setesl(n+lagmax, 4, nfft)

  io = 1
  if (nprt == 0) io = 0
  ia = 1
  if (iar  /=  0) ia = 0

  call ldscmp(7, 0, io*(2*nf+5), 0, 0, 0, 's', &
     lagmax+1+nfft+ia*(3*lagmax+1)+io*(4*nf+10), ldsmin)

  call uaser(nmsub, n, yfft, iar, phi, lagmax, lag, lacov, &
     nf, ldstak, ldsmin, lyfft, nfft, option)

    5 if (ierr /= 0) then
     ierr = 1
     write ( *, 1000)
     return
  end if
!
!  set size of work area.
!
  call stkset (ldstak, 4)
!
!  save number of outstanding stack allocations.
!
  nall0 = stkst(1)

  lspc = nf
  lpcv = 2*nf + 5
  lphi = lagmax
  lacov = lagmax + 1
  lwork = nfft

  fmn = max(fmin, 0.0e0)
  fmx = min(fmax, 0.5e0)
  if (fmn >= fmx) then
    fmn = 0.0e0
    fmx = 0.5e0
  end if

  alpha = 0.95e0
  delta = 1.0e0

  if (iar >= 1) then
!
!  user has chosen order and supplied coefficients.
!  compute residual variance.
!
     call amean(yfft, n, ymean)
     call uasvar (yfft, ymean, n, iar, phi, var)
  end if
!
!  compute autocovariances
!
  acov = stkget(lacov, ifp)
  work = stkget(lwork, ifp)

  call acvff (yfft, n, nfft, ymean, rstak(acov), lagmax, lagmax+1, &
     lyfft, rstak(work), nfft)
!
!  set up additional stack work area, if needed.
!
  if (iar == 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 /= 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

  if (ierr == 1) go to 5
!
!  call the main driver for autoregressive spectrum routines.
!
  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)

  call stkclr(nall0)

  return

 1000 format (/' 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
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 )

!*****************************************************************************80
!
!! UASORD produces coordinates for the spectrum plots.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     alow,aup,bw,spcamn,spcamx,spcfmn,spcfmx,xpltmn,xpltmx,ypltmn, &
     ypltmx
  integer &
     ispc,lpcv,nf,nprt,npts,nspca,nspcf
!
!  array arguments
  real &
     freq(nf),spca(ispc),spcf(ispc),xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)

  real &
     cilow,cimid,ciup,ymax
  integer &
     i,ispca,ispcf
!
!  external subroutines
  external sppltc,sppltd,sppltl
!
!     variable definitions (alphabetically)
!
!     real alow
!        the factor used to compute the lower confidence limits.
!     real aup
!        the factor used to compute the upper confidence limits.
!     real bw
!        the bandwidth.
!     real cilow, cimid, ciup
!        the y axis values for the lower, mid and upper confidence
!        interval points.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     integer i
!        an index variable
!     integer ispc
!         the length of the spectrum arrays.
!     integer ispca, ispcf
!        the index for the Fourier and autoregressive  estimates,
!        respectively.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer npts
!        the number of x, y coordinates to be plotted.
!     integer nspca, nspcf
!        the number of valid spectrum estimates for the autoregressive
!        and Fourier spectrums, respectively.
!     real spca(ispc)
!        the aray containing the autoregressive spectrum estimates.
!     real spcamn, spcamx
!        the minimum and maximum autoregressive spectrum value to be
!        plotted.
!     real spcf(ispc)
!        the array containing the Fourier spectrum estimates.
!     real spcfmn, spcfmx
!        the minimum and maximum Fourier spectrum value to be plotted.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plot.
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plot.
!     real ymax
!        the maximum  actual spectrum value (in decibels) to be plotted.
!     real ypltmn, ypltmx
!        the minimum and mayimum values to be plotted for the x axis.
!
  ispcf = 0
  ispca = nspcf

  if ( nprt < 1 ) then
!
!  set various y axis values for decibel plots
!
    call sppltd (min(spcfmn, spcamn), max(spcfmx, spcamx), &
      alow, aup, ypltmn, ypltmx, cilow, cimid, ciup, ymax)
!
!  set coordinates for decibel plots
!
    do i = 1, nf

      if ( spcfmn <= spcf(i) ) then
        ispcf = ispcf + 1
        xaxis(ispcf) = freq(i)
        yaxis(ispcf) = 10.0e0 * log10(spcf(i)) - ymax
        isym(ispcf) = 1
      end if

      if ( spcamn <= spca(i) ) then
        ispca = ispca + 1
        xaxis(ispca) = freq(i)
        yaxis(ispca) = 10.0e0 * log10(spca(i)) - ymax
        isym(ispca) = 2
      end if

    end do

  else
!
!  set various y axis values for log plots
!
    call sppltl (min(spcfmn, spcamn), max(spcfmx, spcamx), &
      alow, aup, ypltmn, ypltmx, cilow, cimid, ciup)
!
!  set coordinates for log plots
!
    do i = 1, nf

      if ( spcfmn <= spcf(i) ) then
        ispcf = ispcf + 1
        xaxis(ispcf) = freq(i)
        yaxis(ispcf) = spcf(i)
        isym(ispcf) = 1
      end if

      if ( spcamn <= spca(i) ) then
        ispca = ispca + 1
        xaxis(ispca) = freq(i)
        yaxis(ispca) = spca(i)
        isym(ispca) = 2
      end if

    end do

  end if

  npts = nspca + nspcf
!
!  set coordinates for bandwidth and confidence interval.
!
  call sppltc (xaxis, yaxis, isym, npts, xpltmn, xpltmx, bw, cilow, &
     cimid, ciup, lpcv)

  return
end
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 )

!*****************************************************************************80
!
!! UASOUT produces the spectrum plots for the autoregressive spectrum estimates.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real aic(laic)
!        the array contaning akiakes criteria for each order.
!     logical aicprt
!        an indicator variable used to determine if the akiake
!        information criteria and chi squared statistics should
!        be printed.
!     real bw
!        the bandwidth.
!     logical error
!        an error flag
!     real ftest(2,lagmax)
!        the array in which the f ratio and probability are stored.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer idf
!        the effective degrees of freedom.
!     integer ispcer
!        a variable used to designate an error in the spectral
!        estimates.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lag
!        the lag window truncation point used for the Fourier spectrum.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the array aic.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer n
!        the number of observations in the series.
!     character*1 nmsub(6)
!        the name of the calling subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer npts
!        the number of x, y coordinates to be plotted.
!     real phi(lagmax)
!        the array of autoregressive coefficients for the selected
!        order.
!     real prho(1)
!        a dummy variable.
!     real var
!        the one step prediction variance for order iar.
!     real xaxis(lpcv)
!        the x axis values for the spectral plot.
!     real xmn, xmx
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real yaxis(lpcv)
!        the y axis values for the spectral plot.
!     real ymn, ymx
!        *
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
  implicit none

  real bw
  real var
  real xpltmn
  real xpltmx
  real ypltmn
  real ypltmx

  integer &
     iar,idf,ispcer,lag,lagmax,laic,lpcv,n,nprt,npts
  logical &
     aicprt
!
!  array arguments
  real &
     aic(laic),ftest(2,lagmax),phi(lagmax),xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)
  character &
     nmsub(6)*1

  real &
     xmn,xmx,ymn,ymx
  integer &
     ilog
  logical &
     error
!
!  local arrays
  real &
     prho(1)
!
!  print autoregressive model order selection statistics
!
  if ( aicprt ) then

    call versp ( .true. )
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'Autoregressive Order Selection Statistics:'
    write ( *, '(a)' ) ' '

    call aoslst ( prho, aic, ftest, lagmax, laic, iar, phi, var, &
      .false., n )

    write ( *, * )' '

  end if

  call versp ( .true. )

  write ( *, '(a)' ) ' '
  write ( *, '(a,i8)' ) 'Fourier spectrum (+) (lag wind. trunc. pt.=', lag
  write ( *, '(a,f6.4)' ) 'BW =', bw
  write ( *, '(a,i8)' ) 'IDF =', idf
  write ( *, '(a,i8,a)' ) 'and order ', iar, ' autoregressive spectrum (.)'

  if ( ispcer /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'The plot has been supressed because fewer than'
    write ( *, '(a)' ) 'four valid (positive) spectral estimates could be '
    write ( *, '(a)' ) 'computed.'
    return
  end if

  if ( nprt <= 0 ) then
    ilog = 0
  else
    ilog = 1
  end if

  call pplmt ( yaxis, yaxis, xaxis, xaxis, npts, 1, lpcv, ypltmn, &
    ypltmx, ymn, ymx, xpltmn, xpltmx, xmn, xmx, error, nmsub, &
    .false.)

  if (.not.error) then
    call ppmn ( yaxis, yaxis, xaxis, xaxis, npts, 1, lpcv, 1, isym, &
      lpcv, 0, -1, ymn, ymx, xmn, xmx, .false., ilog )
  end if

  if ( xpltmn  /=  0.0e0 .or. xpltmx  /=  0.5e0 ) then
    return
  end if

  write ( *, '(a)' ) '+freq'
  write ( *, '(a)' ) &
    ' period         inf       20.       10.        6.6667    5.' // &
    '        4.        3.3333    2.8571    2.5       2.2222    2.'

  return
end
subroutine uass ( y, n, iar, phi, lagmax, lag, nf, fmin, fmax, &
  nprt, spca, spcf, freq, ldstak )

!*****************************************************************************80
!
!! UASS: user interface for autoregressive spectrum estimation (long call).
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer acov
!        the starting location in rstak for the array of
!        the autocovariance array.
!     integer aic
!        the starting location in the stack for
!        the array containing the aic.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency for which the
!        spectrum estimates are to be computed.
!     real fmn, fmx
!        the maximum and minimum frequency actually used.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     integer ftest
!        the starting location in the stack for
!        the array in which the f ratio and probability are stored.
!     integer ia
!        a variable used to determine the amount of storage required,
!        based on whether or not the model order is to be selected or
!        has been provided.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer isort
!        the starting location in istak for
!        an array used for sorting.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in istak for
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the covariance arrays.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the array aic.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lphi
!        the length of the vector phi.
!     integer lspc
!         the length of the spectrum arrays.
!     integer lwork
!        the length of the work array.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of stack allocations outstanding when this routine
!        was called.
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the type of window to be used.
!     real phi(lagmax)
!        the array of autoregressive coefficients for the
!        selected order.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spca(nf)
!        the array containing the autoregressive spectrum estimates.
!     real spcf(nf)
!        the array containing the Fourier spectrum estimates.
!     real var
!        the one step prediction variance.
!     integer work
!        the starting location in the stack for
!        the work array.
!     integer xaxis
!        the starting location in rstak for
!        the x axis values for the spectrum plot.
!     real y(n)
!        the array containing the observed time series.
!     integer yaxis
!        the starting location in rstak for
!        the y axis values for the spectrum plot.
!     real ymean
!        the mean of the observed time series
!
  implicit none

  integer acov
  integer aic
  real alpha
  double precision dstak(12)
  real delta
  real fmax
  real fmin
  real fmn
  real fmx
  real freq(*)
  integer ftest
  integer ia
  integer iar
  integer ierr
  integer ifp
  integer io
  integer isort
  integer istak(12)
  integer isym
  integer lacov
  integer lag
  integer lagmax
  integer laic
  integer ldsmin
  integer ldstak
  integer lpcv
  integer lphi
  integer lspc
  integer lwork
  integer n
  integer nall0
  integer nf
  character nmsub(6)
  integer nprt
  logical option(4)
  external parzen
  real phi(*)
  real rstak(12)
  real spca(*)
  real spcf(*)
  integer, external :: stkget
  integer, external :: stkst
  real var
  integer work
  integer xaxis
  real y(*)
  integer yaxis
  real ymean

  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'u',       'a',       's',       's',       ' ',       ' '/

  ifp = 3

  option(1) = .false.
  option(2) = .false.
  option(3) = .false.
  option(4) = .true.

  if ( nprt == 0 ) then
    io = 0
  else
    io = 1
  end if

  if ( iar /= 0 ) then
    ia = 0
  else
    ia = 1
  end if

  call ldscmp ( 7, 0, io*(2*nf+5), 0, 0, 0, 's', &
    2*lagmax+2+ia*(3*lagmax+1)+io*(4*nf+10), ldsmin )

  call uaser ( nmsub, n, y, iar, phi, lagmax, lag, lacov, &
    nf, ldstak, ldsmin, n, n, option )

  if ( ierr /= 0 ) then
    ierr = 1
    write ( *, '(a)' )
    write ( *, '(a)' ) 'UASS - Fatal error!'
    write ( *, '(a)' ) '  Nonzero error return from UASER.'
    return
  end if
!
!  Set size of work area.
!
  call stkset ( ldstak, 4 )
!
!  Save number of outstanding stack allocations.
!
  nall0 = stkst(1)

  lspc = nf
  lpcv = 2*nf + 5
  lphi = lagmax
  lacov = lagmax + 1
  lwork = lagmax+1

  fmn = max ( fmin, 0.0e0 )
  fmx = min ( fmax, 0.5e0 )

  if ( fmn  >=  fmx ) then
    fmn = 0.0e0
    fmx = 0.5e0
  end if

  alpha = 0.95e0
  delta = 1.0e0
!
!  Compute autocovariances.
!
  acov = stkget ( lacov, ifp )

  call acvf ( y, n, ymean, rstak(acov), lagmax, lacov )
!
!  user has chosen order and supplied coefficients.
!  compute residual variance.
!
  if ( iar  >=  1 ) then
    call uasvar ( y, ymean, n, iar, phi, var )
  end if
!
!  Set up additional stack work area, if needed.
!
  work = stkget ( lwork, ifp )

  if ( iar == 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 == 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

  if ( ierr == 1 ) then
    ierr = 1
    write ( *, 1000)
    return
  end if
!
!  Call the main driver for autoregressive spectrum routines.
!
  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 )

  call stkclr ( nall0 )

  return

 1000 format (/' 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
subroutine uasvar ( y, ymean, n, iar, phi, var )

!*****************************************************************************80
!
!! UASVAR computes the variance for a given series and autoregressive model.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer i
!        an index variable.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer iar1
!        the value iar + 1.
!     integer j, k
!        index values.
!     integer n
!        the integer number of observations in each series
!     real phi(iar)
!        the array of autoregressive coefficients for the
!        selected order.
!     real res
!        *
!     real rss
!        the one step prediction residual sum of squares.
!     real var
!        the one step prediction variance.
!     real y(n)
!         the array containing the observed time series.
!     real ymean
!        the mean of the observed time series
!
  implicit none

  integer iar
  integer n

  integer i
  integer j
  real phi(iar)
  real res
  real rss
  real var
  real y(n)
  real ymean

  rss = 0.0e0

  do i = iar + 1, n
    res = y(i) - ymean
    do j = 1, iar
      res = res - phi(j) * ( y(i-j) - ymean )
    end do
    rss = rss + res * res
  end do

  var = rss / real ( n - ( iar + 1 ) )

  return
end
subroutine uasv ( acov, lagmax, n )

!*****************************************************************************80
!
!! UASV is the user routine for autoregressive spectrum estimation.
!
!  Discussion:
!
!    This is the user callable routine for autoregressive
!    spectrum estimation when the acvf have previously been
!    computed and stored (short call).
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer lagmax
  integer n
  external parzen
!
!  array arguments
  real &
     acov(*)
!
!  scalars in common
  integer &
     ierr

  real &
     alpha,delta,fmax,fmin,var
  integer &
     iar,lacov,lag,laic,ldsmin,ldstak,lpcv,lphi,lspc, &
     lwork,nf,nprt
!
!  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
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real acov(lagmax+1)
!        the autocovariance computed from the lag product pairs.
!     real aic(101)
!        the array contaning akiakes criteria for each order.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequency for which the
!        spectrum estimates are to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     real ftest(2, 100)
!        the array containing the f ratio and f test.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected
!     integer isort(101)
!        an array used for sorting.
!     integer isym(207)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the covariance arrays.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the array aic.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lphi
!        the length of the vector phi.
!     integer lspc
!         the length of the spectrum arrays.
!     integer lwork
!        the length of the work array.
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the type of window to be used.
!     real phi(100)
!        the array of autoregressive coefficients for the
!        selected order.
!     real spca(101)
!        the aray containing the autoregressive spectrum estimates.
!     real spcf(101)
!        the array containing the Fourier spectrum estimates.
!     real var
!        the one step prediction variance.
!     real work(101)
!        a work area used for the lag windows and for
!        computing the autoregressive coefficients.
!     real xaxis(207)
!        the x axis values for the spectrum plot.
!     real yaxis(207)
!        the y axis values for the spectrum plot.
!
!  set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'u',       'a',       's',       'v',       ' ',       ' '/

  option(1) = .false.
  option(2) = .false.
  option(3) = .true.
  option(4) = .false.

  lag = 0
  iar = 0
  nf = 101
  fmin = 0.0e0
  fmax = 0.5e0
  nprt = -1
  lacov = lagmax+1
  ldstak = 0
  ldsmin = 0

  call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, &
     nf, ldstak, ldsmin, n, n, option)

  if (ierr /= 0) then
     ierr = 1
     write ( *, 1000)
     return
  end if

  lpcv = 207
  laic = 101
  lspc = 101
  lphi = 100
  lwork = 101

  alpha = 0.95e0
  delta = 1.0e0
!
!  call the main driver for autoregressive spectrum routines.
!
  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)

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call uasv (acov, lagmax, n)')
end
subroutine uasvs ( acov, lagmax, y, n, iar, phi, lag, nf, &
  fmin, fmax, nprt, spca, spcf, freq, ldstak )

!*****************************************************************************80
!
!! UASVS is a user routine for autoregressive spectrum estimation.
!
!  Discussion:
!
!    this is the user callable routine for autoregressive
!    spectrum estimation when the acvf have previously been
!    computed and stored (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin
  integer &
     iar,lag,lagmax,ldstak,n,nf,nprt
!
!  array arguments
  real &
     acov(*),freq(*),phi(*),spca(*),spcf(*),y(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,fmn,fmx,var,ymean
  integer &
     aic,ftest,ia,ifp,io,isort,isym,lacov,laic,ldsmin, &
     lpcv,lphi,lspc,lwork,nall0,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external amean,ldscmp,parzen,stkclr,stkset,uasdv,uaser, &
     uasvar
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real acov(lagmax+1)
!        the array of autocovariance estimates.
!     integer aic
!        the starting location in the stack for
!        the array containing the aic.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency for which the
!        spectrum estimates are to be computed.
!     real fmn, fmx
!        the maximum and minimum frequency actually used.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        estimated.
!     integer ftest
!        the starting location in the stack for
!        the array in which the f ratio and probability are stored.
!     integer ia
!        a variable used to determine the amount of storage required,
!        based on whether or not the model order is to be selected or
!        has been provided.
!     integer iar
!        the order of the autoregressive process chosen.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr  /=  0, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required,
!        based on printed output requested.
!     integer isort
!        the starting location in istak for
!        an array used for sorting.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in istak for
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the covariance arrays.
!     integer lag
!        the lag window truncation point used for a specific window.
!     integer lagmax
!        the maximum lag value to be used.
!     integer laic
!        the length of the array aic.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lpcv
!        the length of the plot coordinate vectors.
!     integer lphi
!        the length of the vector phi.
!     integer lspc
!         the length of the spectrum arrays.
!     integer lwork
!        the actual length of the work array.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of stack allocations outstanding when this routine
!        was called.
!     integer nf
!        the number of frequencies for which the spectrum estimates
!        are to be estimated.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the type of window to be used.
!     real phi(lagmax)
!        the array of autoregressive coefficients for the
!        selected order.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spca(nf)
!        the aray containing the autoregressive spectrum estimates.
!     real spcf(nf)
!        the array containing the Fourier spectrum estimates.
!     real var
!        the one step prediction variance.
!     integer work
!        the starting location in the stack for
!        the work array.
!     integer xaxis
!        the starting location in rstak for
!        the x axis values for the spectrum plot.
!     real y(n)
!        the array containing the observed time series.
!     integer yaxis
!        the starting location in rstak for
!        the y axis values for the spectrum plot.
!     real ymean
!        the mean of the observed time series
!
!  set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
   /     'u',       'a',       's',       'v',       's',       ' '/

  ifp = 3

  option(1) = .false.
  option(2) = .false.
  option(3) = .true.
  option(4) = .true.

  lacov = lagmax+1

  io = 1
  if (nprt == 0) io = 0
  ia = 1
  if (iar  /=  0) ia = 0

  call ldscmp(6, 0, io*(2*nf+5), 0, 0, 0, 's', &
     lagmax + 1 + ia*(3*lagmax+1) + io*(4*nf+10), ldsmin)

  call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, &
     nf, ldstak, ldsmin, n, n, option)

  if (ierr /= 0) then
     ierr = 1
     write ( *, 1000)
     return
  end if
!
!  set size of work area.
!
  call stkset (ldstak, 4)
!
!  save number of outstanding stack allocations.
!
  nall0 = stkst(1)

  lspc = nf
  lpcv = 2*nf + 5
  lphi = lagmax
  lwork = lagmax+1

  fmn = max(fmin, 0.0e0)
  fmx = min(fmax, 0.5e0)

  if (fmn >= fmx) then
    fmn = 0.0e0
    fmx = 0.5e0
  end if

  alpha = 0.95e0
  delta = 1.0e0

  if (iar >= 1) then
!
!  user has chosen order and supplied coefficients.
!  compute residual variance.
!
     call amean (y, n, ymean)
     call uasvar (y, ymean, n, iar, phi, var)
  end if
!
!  set up additional stack work area, if needed.
!
  work = stkget(lwork,ifp)
  if (iar == 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 == 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

  if (ierr /= 0) then
     ierr = 1
     write ( *, 1000)
     return
  end if
!
!  call the main driver for autoregressive spectrum routines.
!
  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)

  call stkclr(nall0)

  return

 1000 format (/' 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
subroutine ufparm ( )

!*****************************************************************************80
!
!! UFPARM is a dummy version of the optional user function for NL2SOL.
!
!  Modified:
!
!    30 April 2006
!
  implicit none

  return
end
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 )

!*****************************************************************************80
!
!! UFSDRV is the controlling routine for time series Fourier spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lacov)
!        the autocovariance.
!     real alow
!        a factor used to compute the lower confidence limits.
!     real alpha
!        the desired confidence level.
!     real aup
!        a factor used to compute the upper confidence limits.
!     real bw
!        the bandwidth.
!     real delta
!        the sampling interval.
!     real df
!        the effective degrees of freedom.
!     real fmax, fmin
!        the maximum and minimum frequences at which the
!        spectrum is to be computed.
!     real fmn, fmx
!        the maximum and minimum frequences actually used.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index variable
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ilog
!        a code used to specify the type of plot, where if
!        ilog = 0 the plot is linear/linear, if
!        ilog = 1 the plot is log/linear, if
!        ilog = 2 the plot is linear/log, and if
!        ilog = 3 the plot is log/log.
!     integer isort(nf)
!        the vector used for sorting.
!     integer ispcer
!        an error flag used for the spectrum plots.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the vector acov.
!     integer lag
!        the lag windwo truncation point used for a specific window.
!     integer laglst
!        the last lag before missing data caused an acvf
!        to be unable to be computed.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector work.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in each series
!     logical newpg
!        the logical variable used to determine if output
!        will begin on a new page (true) or not (false).
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     integer nfused
!        the number of frequencies actually used.
!     integer nlppa(lnlppa)
!        the array containing the number of lag product pairs.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer npts
!        the number of x, y coordinates to be plotted.
!     integer nspc
!        the number of valid (positive) spectrum values.
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     integer nwused
!        the number of different bandwidths actually used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     real spcf(ispcf,nw)
!        the arrays in which the spectrum is stored.
!     real spcfmn, spcfmx
!        the minimum and maximum spectrum value to be plotted.
!     logical univar
!        the logical variable used to determine if the output
!        is for univariate (true) or bivariate (false) spectra.
!     external window
!        the subroutine used to compute the window.
!     real work(lwork)
!        the vector of lag windows.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plot.
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real y(ly)
!        the array containing the observed time series.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plots.
!     real ymean
!        the mean of the observed time series
!     real ymiss
!        the user supplied code which is used to determine whether or
!        not an observation in the series is missing.  if y(i) = ymiss,
!        the value is assumed missing, otherwise it is not.
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
  implicit none

  real &
     alpha,delta,fmax,fmin,ymiss
  integer &
     ispcf,lacov,lagmax,ldsmin,ldstak,lnlppa,lpcv,lwork,ly,n, &
     nf,nfft,nprt,nw
!
!  array arguments
  real &
     acov(*),freq(*),spcf(*),work(lwork),xaxis(*),y(*),yaxis(lpcv)
  integer &
     isort(*),isym(*),lags(*),nlppa(*)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  subroutine arguments
  external window
!
!  scalars in common
  integer &
     ierr

  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
!
!  external functions
  integer &
     lstlag
  external lstlag
!
!  common blocks
  common /errchk/ierr

  nfused = nf
  if (option(4)) then
    fmn = max(fmin, 0.0e0)
    fmx = min(fmax, 0.5e0)
    if (fmn >= fmx) then
      fmn = 0.0e0
      fmx = 0.5e0
    end if
  else
!
!  set various values for short forms of call statement
!
    nprt = -1
    fmn = 0.0e0
    fmx = 0.5e0
  end if

  call ufser(nmsub, n, lagmax, lacov, nfused, ispcf, nw, lags, &
    ldstak, ldsmin, ly, nfft, option)

  if (ierr == 1) return

  alpha = 0.95e0
  delta = 1.0e0
!
!  compute covariances
!
  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)

  if (laglst < 1 ) then
    ierr = 2
    return
  end if
!
!  compute the vector of lag window truncation points, ordered
!  smallest to largest.
!
  nwused = nw
  if (.not.option(4)) call ufslag(acov, laglst, lags, n, nw, &
     nwused, lacov)
!
!  begin computing Fourier spectrum for series
!
  univar = .true.

  if (nprt >= 1) then
    ilog = 1
  else
    ilog = 0
  end if

  xpltmn = fmn
  xpltmx = fmx
!
!  set frequencies for the spectrum.
!
  call setfrq(freq, nfused, 2, fmn, fmx, delta)
!
!  compute and plot spectrum values.
!
  newpg = .false.

  do i=1,nwused

    lag = lags(i)
    ispcer = 0

    if ( laglst < lag ) then

      ispcer = 2
      df = 0.0e0

    else

      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)

      if (nprt == 0) then
        cycle
      end if

      ispcer = 0
      call spcck(spcf(1+(i-1)*ispcf), isort, nfused, &
        spcfmn, spcfmx, nspc, ispcer)

      if ( ispcer == 0 ) then

        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)

      end if

    end if

    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)

    newpg = .true.

  end do

  return
end
subroutine ufser ( nmsub, n, lagmax, lacov, nf, ispcf, nw, &
  lags, ldstak, ldsmin, lyfft, nfft, option )

!*****************************************************************************80
!
!! UFSET checks errors for time series Fourier univariate spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ispcf,lacov,lagmax,ldsmin,ldstak,lyfft,n,nf,nfft,nw
!
!  array arguments
  integer &
     lags(*)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr
!
!
  integer &
     i,nv
  logical &
     head
!
!  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
!
!  external subroutines
  external eisge,eisii,eivii
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     logical err(15)
!        value(s) indicating whether an error was detected (true) or not
!        (false).
!     logical head
!        a flag indicating whether the heading should be printed
!        (true) or not (false).  if a heading is printed, the value
!        of head will be changed to false.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to specify the lag window truncation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     character*1 lispcf(8), llacov(8), llagmx(8),
!    *   llags(8), llgmx1(8), llds(8), ln(8), lnf(8), lnm1(8),
!    *   lnw(8), llyfft(8), l1(8)
!        the array(s) containing the name(s) of the argument(s)
!        checked for errors.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in the series.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     character*1 nmsub(6)
!        the array containing the name of the user called subroutine.
!     integer nv
!        the number of violations found when checking vector lags.
!     integer nw
!        the argument used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!
!     set up name arrays
!
  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', &
     ' ',' ',' ',' ',' ',' ',' '/

  ierr = 0
  head = .true.
  err(1:15) = .false.

  call eisge(nmsub, ln, n, 17, 1, head, err(1), ln)

  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

  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)

      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

        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

  do i=1,15
     if (err(i)) ierr = 1
  end do

  return
end
subroutine ufsest ( acov, w, lag, spcf, ispcf, lacov, lw, nf, freq, &
  delta )

!*****************************************************************************80
!
!! UFSEST computes the spectra and the confidence limits.
!
!  Discussion:
!
!    this routine computes the spectrum, spcf, and
!    their lower and upper confidence limits, spclcl and spcucl,
!    respectively.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     delta
  integer &
     ispcf,lacov,lag,lw,nf
!
!  array arguments
  real &
     acov(lacov),freq(nf),spcf(ispcf),w(lw)
!
!
  real &
     c,pi,v0,v1,v2
  integer &
     i,k,kk
!
!  external subroutines
  external getpi
!
!
!     variable definitions (alphabetically)
!
!     real acov(lacov)
!        the autocovariances of the series.
!     real c
!        a value used to compute the spectrum values.
!     real delta
!        the sampling interval.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index variable
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer k, kk
!        indexing variables.
!     integer lacov
!        the length of vector acov.
!     integer lag
!        the lag window truccation point.
!     integer lw
!        the length of the vector w.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     real pi
!        the value of pi.
!     real spcf(ispcf)
!        the arrays in which the spectrum is stored.
!     real v0, v1, v2
!        constants used for computing the spectrum values.
!     real w(lw)
!        the vector of lag windows.
!
  call getpi(pi)
!
!  compute the spectrum and its confidence limits.
!
  do i=1,nf
     c = cos(2.0e0*pi*freq(i))
     v0 = 0.0e0
     v1 = 0.0e0
     do k=1,lag
        kk = lag + 1 - k
        v2 = 2.0e0*c*v1 - v0 + w(kk+1)*acov(kk+1)
        v0 = v1
        v1 = v2
     end do
     spcf(i) = delta*(acov(1)*w(1)+2.0e0*(v1*c-v0))
     if (spcf(i)<0.0e0) spcf(i) = 0.0e0
  end do

  return
end
subroutine ufs ( y, n )

!*****************************************************************************80
!
!! UFS: user routine for time series Fourier spectrum analysis (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr

  real &
     alpha,delta,fmax,fmin,ymiss
  integer &
     ispcf,lacov,lagmax,ldsmin,ldstak,lnlppa,lpcv,lwork, &
     ly,nf,nprt,nw
!
!  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
!
!  external subroutines
  external parzen,setlag,ufsdrv
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real acov(101)
!        the autocovariance at lag zero (biased variance).
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequences at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer isort(101)
!        an array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer isym(106)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(1)
!        a dummy array when the series does not contain missing values.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real spcf(101,4)
!        the arrays in which the spectrum is stored.
!     real work(101)
!        the vector of lag windows.
!     real xaxis(106)
!        the x axis values for the spectrum plot.
!     real y(n)
!         the array containing the observed time series.
!     real yaxis(106)
!        the y axis values for the spectrum plot.
!     real ymiss
!        a dummy variable when the series do not contain missing values
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s',' ',' ',' '/

  option(4) = .false.
  option(3) = .false.
  option(2) = .false.
  option(1) = .false.

  ldstak = 0
  ldsmin = 0

  ispcf = 101
  lacov = 101
  lnlppa = 1
  ly = n
  lpcv = 106
  lwork = 101
  nf = 101
  ymiss = 1.0e0
!
!  set maximum lag value to be used.
!  and number of lag window truncation points to use.
!
  call setlag(n, lagmax)
  nw = 4
!
!  call the controlling routine for Fourier spectrum routines
!  for series with missing data.
!
  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)

  if ( ierr /= 0 ) then
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufs (y, n)')
end
subroutine ufsf ( yfft, n, lyfft, ldstak )

!*****************************************************************************80
!
!! UFSF: user routine for Fourier spectrum analysis using fft (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(101)
!        the autocovariance at lag zero (biased variance).
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequences at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp = 3 indicates
!        real and ifp=4 indicates double precision.
!     integer isort(101)
!        an array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer isym(106)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer lyfft
!        the length of the vector yfft.
!     integer n
!        the integer number of observations in each series
!     integer nall0
!        the number of allocations outstanding at the time that
!       this routine was called.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nfft
!        the number of observations in the extended series.
!     integer nlppa(1)
!        a dummy array when the series does not contain missing values.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spcf(101,4)
!        the arrays in which the spectrum is stored.
!     integer work
!        the starting location in the work area for array work.
!     real xaxis(106)
!        the x axis values for the spectrum plot.
!     real yfft(lyfft)
!        the array containing the observed time series.
!     real yaxis(106)
!        the y axis values for the spectrum plot.
!     real ymiss
!        a dummy variable when the series do not contain missing values
!
  implicit none

  integer &
     ldstak,lyfft,n
!
!  array arguments
  real &
     yfft(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     alpha,delta,fmax,fmin,ymiss
  integer &
     ifp,ispcf,lacov,lagmax,ldsmin,lnlppa,lpcv,lwork, &
     nf,nfft,nprt,nw,work
!
!  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
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external ldscmp,parzen,setesl,setlag,stkset,ufsdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','f',' ',' '/

  option(4) = .false.
  option(3) = .false.
  option(2) = .false.
  option(1) = .true.
!
!  set maximum lag value to be used.
!  set extended series length.
!  set number of lag window truncation points to use.
!
  call setlag(n, lagmax)
  call setesl(n+lagmax, 4, nfft)
  nw = 4

  ispcf = 101
  lacov = 101
  lnlppa = 1
  lpcv = 106
  lwork = nfft
  nf = 101
  ymiss = 1.0e0
!
!  compute minimum allowable stack length
!
  call ldscmp ( 1, 0, 0, 0, 0, 0, 's', nfft, ldsmin )
!
!  set size of work area.
!  set the number of outstanding allocations.
!  set the stack allocation type.
!
  call stkset ( ldstak, 4 )

  ifp = 3
!
!  set starting locations in the work area for various arrays.
!
  if ((ldsmin <= ldstak) .and. (ldsmin >= 7)) then
     work = stkget(lwork,ifp)
  else
     work = 1
  end if
!
!  call the controlling routine for Fourier spectrum routines
!  for series with missing data.
!
  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)

  if (ierr /= 0) then
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufsf (yfft, n, lyfft, ldstak)')
end
subroutine ufsfs ( yfft, n, lyfft, ldstak, nw, lags, nf, fmin, fmax, &
  nprt, spcf, ispcf, freq )

!*****************************************************************************80
!
!! UFSFS: user routine for Fourier spectrum analysis using the fft (long call).
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real fmax
  real fmin
  external parzen

  integer &
     ispcf,ldstak,lyfft,n,nf,nprt,nw
!
!  array arguments
  real &
     freq(*),spcf(*),yfft(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,ymiss
  integer &
     acov,ifp,io,isort,isym,lacov,lagmax,ldsmin,lnlppa, &
     lpcv,lwork,nall0,nfft,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12),nlppa(1)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     integer acov
!        the starting location in rstak for the acvf vector.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the spectrum
!        is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index variable
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required
!        based on printed output requested.
!     integer isort
!        the starting location for the array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for array isym.
!     integer lacov
!        the length of vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to specify the lag window truncation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer lyfft
!        the length of the vector y.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of allocations outstanding at the time that
!        this routine was called.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(1)
!        a dummy array for series without missing values.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spcf(ispcf,nw)
!        the arrays in which the spectrum is stored
!        for each lag window.
!     integer work
!        the starting location in the work area for array work.
!     integer xaxis
!        the starting location in the work area for array xaxis.
!     real yfft(lyfft)
!        the array containing the observed time series.
!     integer yaxis
!        the starting location in the work area for array yaxis.
!     real ymiss
!        the missing value code for the series.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','f','s',' '/

  option(4) = .true.
  option(3) = .false.
  option(2) = .false.
  option(1) = .true.
!
!  set maximum lag value to be used.
!
  if ( nw <= 0 ) then
    lagmax = n - 1
  else
    lagmax = maxval ( lags(1:nw) )
  end if

  lacov = lagmax + 1
  lnlppa = 1
!
!  set extended series length
!
  call setesl(n+lagmax, 4, nfft)
!
!  compute minimum allowable stack length
!
  io = 1
  if (nprt == 0) io = 0

  call ldscmp(5, 0, io*(nf+5), 0, 0, 0, 's', &
     lagmax+1+nfft+io*(2*nf+10), ldsmin)

  lpcv = nf + 5
  lwork = nfft
!
!  set size of work area.
!  set the number of outstanding allocations.
!  set the stack allocation type.
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays.
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 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 /= 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
!
!  call the controlling routine for Fourier spectrum routines
!
  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)

  call stkclr(nall0)

  if (ierr /= 0) then
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufsfs (yfft, n, lyfft, ldstak,'/ &
     '      +            nw, lags, nf, fmin, fmax, nprt,'/ &
     '      +            spcf, ispcf, freq)')
end
subroutine ufslag ( acov, lagmax, lags, n, nw, nwused, lacov )

!*****************************************************************************80
!
!! UFSLAG computes the lag window truncation points for spectrum analysis.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     lacov,lagmax,n,nw,nwused
!
!  array arguments
  real &
     acov(lacov)
  integer &
     lags(nw)

  real &
     acovmx,p95lim
  integer &
     i,j,k,lag,nwm1
!
!     variable definitions (alphabetically)
!
!     real acov(lacov)
!        the array in which the autocovariances are stored
!     real acovmx
!        the maximum autocovariance value.
!     integer i
!        an index variable
!     integer j, k
!        index variables.
!     integer lacov
!        the length of vector acov.
!     integer lag, lagmax
!        the indexing variable indicating the lag value of the
!        autocovariance being computed and the maximum lag to be used,
!        respectively.
!     integer lags(nw)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer n
!        the integer number of observations in each series
!     integer nw
!        the number of different bandwidths requested.
!     integer nwm1, nwused
!        the number of different bandwidths minus 1, and the
!        actual number of bandwidths actually used.
!     real p95lim
!        the 95 percent confident limit for white noise.
!
  lags(nw) = lagmax
  if (lags(nw) <= 32) go to 30
!
!  compute 95 percent confidence limits on autocovariances,
!  assuming white noise.
!
  p95lim = 1.96e0 * acov(1) / sqrt(real(n))
!
!  check for first acvf exceeding 95 percent limit on white noise
!
  do i = 1, lagmax
     lag = lagmax + 1 - i
     if (abs(acov(lag + 1))  >=  p95lim) go to 30
     lags(nw) = lags(nw) - 1
  end do
!
!  if no acvf exceeds white noise limits, check for largest acvf.
!
  lags(nw) = 1
  acovmx = abs(acov(2))

  do lag = 1, lagmax
     if ( acovmx < abs(acov(lag + 1)) ) then
       lags(nw) = lag
       acovmx = abs(acov(lag + 1))
    end if
  end do
!
!  compute lag window truncation points
!
   30 continue

  lags(nw) = int ( real ( lags(nw) ) * 3.0e0 / 2.0e0 )
  if (lags(nw) < 32) lags(nw) = 32
  if (lags(nw) > lagmax) lags(nw) = lagmax
  nwused = nw
  if (nw == 1) return
  nwm1 = nw - 1
  do i = 1, nwm1
     k = nw - i
     lags(k) = lags(k + 1) / 2
  end do
!
!  check whether all nw lag window truncation points can be used.
!
  nwused = nw
  if (lags(1)  >=  4) return
!
!  reconsturct -lags- vector if not all truncation points are
!  to be used
!
  do i = 2, nw
    nwused = nwused - 1
    if (lags(i)  >=  4) then
      exit
    end if
  end do

  do i = 1, nwused
     j = nw - nwused + i
     lags(i) = lags(j)
  end do

  return
end
subroutine ufsm ( y, ymiss, n )

!*****************************************************************************80
!
!! UFSM: user routine, Fourier spectrum analysis with missing data (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     ymiss
  integer &
     n
!
!  array arguments
  real &
     y(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     alpha,delta,fmax,fmin
  integer &
     ispcf,lacov,lagmax,ldsmin,ldstak,lnlppa,lpcv,lwork, &
     ly,nf,nprt,nw
!
!  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
!
!  external subroutines
  external ecvf,parzen,setlag,ufsdrv
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real acov(101)
!        the autocovariance at lag zero (biased variance).
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequences at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer isort(101)
!        an array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer isym(106)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(101)
!        the array containing the number of lag product pairs.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real spcf(101,4)
!        the arrays in which the spectrum is stored.
!     real work(101)
!        the vector of lag windows.
!     real xaxis(106)
!        the x axis values for the spectrum plot.
!     real y(n)
!        the array containing the observed time series.
!     real yaxis(106)
!        the y axis values for the spectrum plot.
!     real ymiss
!        the user supplied code which is used to determine whether or
!        not an observation in the series is missing.  if y(i) = ymiss,
!        the value is assumed missing, otherwise it is not.
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','m',' ',' '/
!
!  set up
!
  option(4) = .false.
  option(3) = .false.
  option(2) = .true.
  option(1) = .false.

  ldstak = 0
  ldsmin = 0

  ispcf = 101
  lacov = 101
  lnlppa = 101
  ly = n
  lpcv = 106
  lwork = 101
  nf = 101
!
!  set maximum lag value to be used.
!  and number of lag window truncation points to use.
!
  call setlag(n, lagmax)
  nw = 4
!
!  call the controlling routine for Fourier spectrum routines
!  for series with missing data.
!
  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)
!
!  check for errors
!
  if (ierr == 0) return

  if (ierr == 2) call ecvf(nmsub)
  ierr = 1
  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufsm (y, ymiss, n)')
end
subroutine ufsmn ( acov, nlppa, lag, df, nf, freq, alpha, bw, spcf, &
  alow, aup, lacov, ispcf, window, w, lw, n, delta, miss, lnlppa )

!*****************************************************************************80
!
!! UFSMN computes autocorrelations and partial autocorrelations of time series.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     alow,alpha,aup,bw,delta,df
  integer &
     ispcf,lacov,lag,lnlppa,lw,n,nf
  logical &
     miss
!
!  array arguments
  real &
     acov(lacov),freq(nf),spcf(ispcf),w(lw)
  integer &
     nlppa(lnlppa)
!
!  subroutine arguments
  external window
!
!  external functions
  real &
     ppfchs
  external ppfchs
!
!  external subroutines
  external dfbw,dfbwm,ufsest
!
!     variable definitions (alphabetically)
!
!     real acov(lacov)
!        the autocovariances of the series.
!     real alow
!        a factor used to compute the lower confidence limits.
!     real alpha
!        the desired confidence level.
!     real aup
!        a factor used to compute the upper confidence limits.
!     real bw
!        the bandwidth.
!     real delta
!        the sampling interval.
!     real df
!        the effective degrees of freedom.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer lacov
!        the length of vector acov.
!     integer lag
!        the variable indicating the lag value being examined.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lw
!        the length of the vector w.
!     logical miss
!        an indicator variable which designates whether there are
!        missing values (true) or not (false)
!     integer n
!        the number of observations in the time series.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(lnlppa)
!        the numbers of lagged product pairs in each acvf value.
!     real spcf(ispcf)
!        the array in which the spectrum is stored.
!     real w(lw)
!        the vector of lag windows.
!     external window
!        the name of the window computing subroutine.
!
!  compute the window, effective degrees of freedom and
!  bandwidth based on the window.
!
  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)
!
!  compute the spectrum
!
  call ufsest(acov, w, lag, spcf, ispcf, lacov, lw, nf, freq, delta)
!
!  compute -alpha- percent point function value for
!  spectrum window being used.
!
  alow = df/ppfchs(0.5e0+alpha/2.0e0,nint(df))
  aup = df/ppfchs(0.5e0-alpha/2.0e0,nint(df))

  return
end
subroutine ufsms ( y, ymiss, n, nw, lags, nf, fmin, fmax, nprt, &
  spcf, ispcf, freq, ldstak )

!*****************************************************************************80
!
!! UFSMS: time series Fourier spectrum analysis with missing data (long call).
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real fmax
  real fmin
  external parzen
  real ymiss

  integer &
     ispcf,ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     freq(*),spcf(*),y(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     alpha,delta
  integer &
     acov,ifp,io,isort,isym,lacov,lagmax,ldsmin,lnlppa, &
     lpcv,lwork,ly,nall0,nlppa,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     integer acov
!        the starting location in rstak for the acvf vector.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the spectrum
!        is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index variable
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required
!        based on printed output requested.
!     integer isort
!        the starting location for the array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for array isym.
!     integer lacov
!        the length of vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to specify the lag window truncation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of allocations outstanding at the time that
!        this routine was called.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa
!        the starting location in istak for the array containing
!        the numbers of lagged product pairs used for each acvf.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spcf(ispcf,nw)
!        the arrays in which the spectrum is stored
!        for each lag window.
!     integer work
!        the starting location in the work area for array window.
!     integer xaxis
!        the starting location in the work area for array xaxis.
!     real y(n)
!        the array containing the observed time series.
!     integer yaxis
!        the starting location in the work area for array yaxis.
!     real ymiss
!        the missing value code for the series.
!
!  set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','m','s',' '/

  option(4) = .true.
  option(3) = .false.
  option(2) = .true.
  option(1) = .false.
!
!  set maximum lag value to be used.
!
  if ( nw <= 0 ) then
    lagmax = n - 1
  else
    lagmax = maxval ( lags(1:nw) )
  end if

  lacov = lagmax + 1
  lnlppa = lagmax + 1
!
!  compute minimum allowable stack length
!
  io = 1
  if (nprt == 0) io = 0

  call ldscmp(6, 0, lagmax+1+io*(nf+5), 0, 0, 0, 's', &
     2*lagmax+2+io*(2*nf+10), ldsmin)

  ly = n
  lnlppa = lacov
  lpcv = nf + 5
  lwork = lagmax+1
!
!  set size of work area.
!  set the number of outstanding allocations.
!  set the stack allocation type.
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  Set starting locations in the work area for various arrays.
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 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 /= 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
!
!  Call the controlling routine for Fourier spectrum routines
!  for series with missing data.
!
  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)

  call stkclr ( nall0 )
!
!  check for errors
!
  if (ierr == 0) return

  if (ierr == 2) then
    call ecvf(nmsub)
  end if

  ierr = 1
  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufsms (y, ymiss, n,'/ &
     '      +            nw, lags, nf, fmin, fmax, nprt,'/ &
     '      +            spcf, ispcf, freq, ldstak)')
end
subroutine ufsmv ( acov, nlppa, lagmax, n )

!*****************************************************************************80
!
!! UFSMV: Fourier spectrum analysis, missing data, user ACVF values (short).
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real acov(lagmax+1)
!        the autocovariance at lag zero (biased variance).
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequences at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer isort(101)
!        an array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer isym(106)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(lagmax+1)
!        the array containing the number of lag product pairs.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real spcf(101,4)
!        the arrays in which the spectrum is stored.
!     real work(101)
!        the vector of lag windows.
!     real xaxis(106)
!        the x axis values for the spectrum plot.
!     real y(1)
!        a dummy array.
!     real yaxis(106)
!        the y axis values for the spectrum plot.
!     real ymiss
!        a dummy variable.
!
  implicit none

  real acov(*)
  integer ierr
  integer lagmax
  integer n
  integer nlppa(*)
  external parzen

  real &
     alpha,delta,fmax,fmin,ymiss
  integer &
     ispcf,lacov,ldsmin,ldstak,lnlppa,lpcv,lwork,ly,nf, &
     nprt,nw
!
!  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
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','m','v',' '/

  option(4) = .false.
  option(3) = .true.
  option(2) = .true.
  option(1) = .false.

  ldstak = 0
  ldsmin = 0

  ymiss = 1.0e0
  lacov = lagmax+1

  ispcf = 101
  ly = 1
  lnlppa = lacov
  lpcv = 106
  lwork = 101
  nf = 101
!
!  set number of lag window truncation points
!
  nw = 4
!
!  call the controlling routine for Fourier spectrum routines
!  for series with missing data.
!
  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 )
!
!  check for errors
!
  if (ierr == 0) return

  if (ierr == 2) call ecvf(nmsub)
  ierr = 1
  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufsmv (acov, nlppa, lagmax, n)')
end
subroutine ufsmvs ( acov, nlppa, lagmax, n, nw, lags, nf, &
  fmin, fmax, nprt, spcf, ispcf, freq, ldstak )

!*****************************************************************************80
!
!! UFSMVS: time series Fourier spectrum analysis with missing data (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin
  integer &
     ispcf,lagmax,ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     acov(*),freq(*),spcf(*)
  integer &
     lags(*),nlppa(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
!
  real &
     alpha,delta,ymiss
  integer &
     ifp,io,isort,isym,lacov,ldsmin,lnlppa,lpcv,lwork,ly, &
     nall0,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12),y(1)
  integer &
     istak(12)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external ecvf,ldscmp,parzen,stkclr,stkset,ufsdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real acov(lagmax+1)
!        the autocovariances of the series.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the spectrum
!        is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required
!        based on printed output requested.
!     integer isort
!        the starting location for the array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for array isym.
!     integer lacov
!        the length of the acvf vectors.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to specify the lag window truncation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of allocations outstanding at the time that
!        this routine was called.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(lagmax+1)
!        the array containing the number of lag product pairs.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spcf(ispcf,nw)
!        the arrays in which the spectrum is stored
!        for each lag window.
!     integer work
!        the starting location in rstak for
!        the work vector.
!     integer xaxis
!        the starting location in the work area for array xaxis.
!     real y(1)
!        a dummy array.
!     integer yaxis
!        the starting location in the work area for array yaxis.
!     real ymiss
!        a dummy variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','m','v','s'/

  option(4) = .true.
  option(3) = .true.
  option(2) = .true.
  option(1) = .false.
!
!  compute minimum allowable stack length
!
  io = 1
  if (nprt == 0) io = 0

  call ldscmp(4, 0, io*(nf+5), 0, 0, 0, 's', &
     lagmax+1+io*(2*nf+10), ldsmin)

  ymiss = 1.0e0
  lacov = lagmax+1

  ly = 1
  lnlppa = lacov
  lpcv = nf + 5
  lwork = lagmax+1
!
!  set size of work area.
!  set the number of outstanding allocations.
!  set the stack allocation type.
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays.
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then
     work = 1
     xaxis = 1
     yaxis = 1
     isym = 1
     isort = 1
  else
     work = stkget(lwork,ifp)
     if (nprt /= 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
!
!  call the controlling routine for Fourier spectrum routines
!  for series with missing data.
!
  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)

  call stkclr(nall0)
!
!  check for errors
!
  if (ierr == 0) return

  if (ierr == 2) call ecvf(nmsub)
  ierr = 1
  write ( *,1000)
  return

 1000 format (/' 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
subroutine ufsout ( xaxis, yaxis, isym, npts, bw, idf, lag, laglst, &
  newpg, ispcer, lpcv, xpltmn, xpltmx, ypltmn, ypltmx, ilog, &
  phas, freq, nf, univar, nmsub )

!*****************************************************************************80
!
!! UFSOUT produces the Fourier bivariate spectrum output.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     bw,xpltmn,xpltmx,ypltmn,ypltmx
  integer &
     idf,ilog,ispcer,lag,laglst,lpcv,nf,npts
  logical &
     newpg,univar
!
!  array arguments
  real &
     freq(nf),phas(nf),xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr

  real &
     pi,xmn,xmx,ymn,ymx
  integer &
     i
  logical &
     error
!
!  external subroutines
  external getpi,pplmt,ppmn,versp
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real bw
!        the bandwidth.
!     logical error
!        an error flag
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer idf
!        the effective degrees of freedom.
!     integer ierr
!        the error flag.
!     integer ilog
!        a code used to specify the type of plot, where if
!        ilog = 0 the plot is linear/linear, if
!        ilog = 1 the plot is log/linear, if
!        ilog = 2 the plot is linear/log, and if
!        ilog = 3 the plot is log/log.
!     integer ispcer
!        a variable used to designate an error in the spectrum
!        values.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lag
!        the lag window truncation point.
!     integer laglst
!        the last lag before missing data caused the acvf of either
!        series 1 or 2 not to be computed.
!     integer lpcv
!        the length of the vectors used for plotting.
!     logical newpg
!        the logical variable used to determine if output
!        will begin on a new page (true) or not (false).
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     character*1 nmsub(6)
!        the name of the calling subroutine.
!     integer npts
!        the number of coordinates to be plotted.
!     real phas(nf)
!        the phase component of the bivariate spectra.
!     real pi
!        the value of pi.
!     logical univar
!        the logical variable used to determine if the output
!        is for univariate (true) or bivariate (false) spectra.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plot.
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plot.
!     real ypltmn, ypltmx
!        the minimum and maximum values to be plotted for the y axis.
!
!   set logical unit number for output and set output width.
!
  call getpi(pi)

  if (newpg) write ( *,1010)

  if ( 2 <= ispcer  ) then
    call versp(.true.)
    write ( *,1060) laglst, lag
    return
  end if

  call versp(.true.)
  if (.not.univar) write ( *,1070)
  if (univar) write ( *,1080)
  write ( *,1020) lag, bw, idf

  if ( ispcer /= 0 ) then

    write ( *,1050)

  else
!
!  print plots
!
!  plot squared coherency component of spectrum
!
    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 == 0.0e0 .and. xpltmx == 0.5e0) write ( *, 1030)

  end if

  if (univar) return

  do i=1,nf
     xaxis(i) = freq(i)
     xaxis(nf+i) = freq(i)
     yaxis(i) = phas(i)
     if (phas(i) > 0.0e0) then
        yaxis(nf+i) = phas(i) - 2*pi
     else if (phas(i)<0.0e0) then
        yaxis(nf+i) = phas(i) + 2*pi
     else
        yaxis(nf+i) = 0.0e0
     end if
  end do
!
!  plot smoothed phase component of spectrum
!
  write ( *,1010)
  call versp(.true.)
  write ( *,1000)
  write ( *,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 == 0.0e0 .and. xpltmx == 0.5e0) write ( *, 1030)
  end if

  return

 1000 format (' -- smoothed Fourier spectrum (phase component) --')
 1010 format ('1')
 1020 format ('    (parzen window with lag wind. trunc. pt.=', i5, 1x, &
     '/ bw=', f6.4, 1x, '/ edf=', i6, ')')
 1030 format ('+freq'/' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, &
     '6.6667', 4x, '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, &
     '2.5', 7x, '2.2222', 4x, '2.')
 1050 format (//' the plot has been supressed because no'/ &
     ' positive spectrum values were computed.')
 1060 format (//' the largest lag window truncation point which can'/ &
     ' be used is ', i5, '.'/' the spectrum for the requested la', &
     'g window', ' point of ', i5, ','/' therefore, cannot be co', &
     'mputed.')
 1070 format (' -- smoothed Fourier spectrum (squared coherency', &
     ' component) (+), 95 pct. confidence limits (.)', &
     ' and 95 pct. significance level (-) --')
 1080 format (' -- smoothed Fourier spectrum --')
end
subroutine ufspcv ( spcf, spcmn, spcmx, freq, nf, xaxis, yaxis, &
  isym, npts, ispcf, lpcv, nspc, bw, alow, aup, xpltmn, xpltmx, &
  ypltmn, ypltmx, nprt )

!*****************************************************************************80
!
!! UFSPCV produces coordinates for the spectrum plots.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     alow,aup,bw,spcmn,spcmx,xpltmn,xpltmx,ypltmn,ypltmx
  integer &
     ispcf,lpcv,nf,nprt,npts,nspc
!
!  array arguments
  real &
     freq(nf),spcf(ispcf),xaxis(lpcv),yaxis(lpcv)
  integer &
     isym(lpcv)

  real &
     cilow,cimid,ciup,ymax
  integer &
     i,ispcfw
!
!     variable definitions (alphabetically)
!
!     real alow, aup
!        factors used to compute the confidence intervals.
!     real bw
!       the bandwidth.
!     real cilow, cimid, ciup
!        the y axis values for the lower  mid and upper confidence
!        interval points.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index variable
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer ispcfw
!        an index variable.
!     integer isym(lpcv)
!        the array containing the code for the plot symbols.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer npts
!        the number of coordinates to be plotted.
!     integer nspc
!        the number of valid spectrum values.
!     real spcf(ispcf)
!        the arrays in which the spectrum is stored
!        for each lag window.
!     real spcmn, spcmx
!        the minimum and maximum spectrum value to be plotted.
!     real xaxis(lpcv)
!        the x axis values for the spectrum plot.
!     real xpltmn, xpltmx
!        the minimum and maximum values to be plotted for the x axis.
!     real yaxis(lpcv)
!        the y axis values for the spectrum plots.
!     real ymax
!        the maximum actual spectrum value (in decibels) to be plotted.
!     real ypltmn, ypltmx
!        the minimum and maximum vaues to be plotted for the y axis.
!
  ispcfw = 0

  if ( nprt < 1 ) then
!
!  set various y axis values for decibel plots
!
    call sppltd (spcmn, spcmx, alow, aup, ypltmn, ypltmx, &
      cilow, cimid, ciup, ymax)
!
!  set coordinates for decibel plots
!
    do i = 1, nf
      if ( spcmn <= spcf(i) ) then
        ispcfw = ispcfw + 1
        xaxis(ispcfw) = freq(i)
        yaxis(ispcfw) = 10.0e0 * log10(spcf(i)) - ymax
        isym(ispcfw) = 1
      end if
    end do

  else
!
!  set various y axis values for log plots
!
    call sppltl (spcmn, spcmx, alow, aup, ypltmn, ypltmx, &
      cilow, cimid, ciup)
!
!  set coordinates for log plots
!
    do i = 1, nf
      if ( spcmn <= spcf(i) ) then
        ispcfw = ispcfw + 1
        xaxis(ispcfw) = freq(i)
        yaxis(ispcfw) = spcf(i)
        isym(ispcfw) = 1
      end if
    end do

  end if

  npts = nspc
!
!  set coordinates for bandwidth and confidence interval.
!
  call sppltc (xaxis, yaxis, isym, npts, xpltmn, xpltmx, bw, cilow, &
     cimid, ciup, lpcv)

  return
end
subroutine ufss ( y, n, nw, lags, nf, fmin, fmax, nprt, &
  spcf, ispcf, freq, ldstak )

!*****************************************************************************80
!
!! UFSS: time series Fourier spectrum analysis (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin
  integer &
     ispcf,ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     freq(*),spcf(*),y(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)
!
  real &
     alpha,delta,ymiss
  integer &
     acov,ifp,io,isort,isym,lacov,lagmax,ldsmin,lnlppa, &
     lpcv,lwork,ly,nall0,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12)
  integer &
     istak(12),nlppa(1)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external ldscmp,parzen,stkclr,stkset,ufsdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     integer acov
!        the starting location in rstak for the acvf vector.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the spectrum
!        is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer i
!        an index variable
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required
!        based on printed output requested.
!     integer isort
!        the starting location for the array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for array isym.
!     integer lacov
!        the length of vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to specify the lag window truncation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of allocations outstanding at the time that
!        this routine was called.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(1)
!        a dummy array for series without missing values.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spcf(ispcf,nw)
!        the arrays in which the spectrum is stored
!        for each lag window.
!     integer work
!        the starting location in the work area for array window.
!     integer xaxis
!        the starting location in the work area for array xaxis.
!     real y(n)
!         the array containing the observed time series.
!     integer yaxis
!        the starting location in the work area for array yaxis.
!     real ymiss
!        the missing value code for the series.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','s',' ',' '/

  option(4) = .true.
  option(3) = .false.
  option(2) = .false.
  option(1) = .false.
!
!  set maximum lag value to be used.
!
  if ( nw <= 0 ) then
    lagmax = n - 1
  else
    lagmax = maxval ( lags(1:nw) )
  end if

  lacov = lagmax + 1
  lnlppa = 1
!
!  compute minimum allowable stack length
!
  io = 1
  if (nprt == 0) io = 0

  call ldscmp(5, 0, io*(nf+5), 0, 0, 0, 's', &
     2*lagmax+2+io*(2*nf+10), ldsmin)

  ly = n
  lpcv = nf + 5
  lwork = lagmax+1
!
!  set size of work area.
!  set the number of outstanding allocations.
!  set the stack allocation type.
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  set starting locations in the work area for various arrays.
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 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 /= 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
!
!  call the controlling routine for Fourier spectrum routines
!
  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)

  call stkclr(nall0)

  if (ierr == 0) return

  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufss (y, n,'/ &
     '      +           nw, lags, nf, fmin, fmax, nprt,'/ &
     '      +           spcf, ispcf, freq, ldstak)')
end
subroutine ufsv ( acov, lagmax, n )

!*****************************************************************************80
!
!! UFSV: Fourier spectrum analysis, user supplied ACVF values (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     lagmax,n
!
!  array arguments
  real &
     acov(*)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     alpha,delta,fmax,fmin,ymiss
  integer &
     ispcf,lacov,ldsmin,ldstak,lnlppa,lpcv,lwork,ly,nf, &
     nprt,nw
!
!  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
!
!  external subroutines
  external parzen,ufsdrv
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     real acov(lagmax+1)
!        the autocovariance at lag zero (biased variance).
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     real fmax, fmin
!        the maximum and minimum frequences at which the
!        spectrum is to be computed.
!     real freq(101)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     integer isort(101)
!        an array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer isym(106)
!        the array containing the code for the plot symbols.
!     integer lacov
!        the length of the vector acov.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(4)
!        the array used to store the lag window truccation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in each series
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(1)
!        a dummy array for series without missing values.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real spcf(101,4)
!        the arrays in which the spectrum is stored.
!     real work(101)
!        the vector of lag windows.
!     real xaxis(106)
!        the x axis values for the spectrum plot.
!     real y(1)
!        a dummy array.
!     real yaxis(106)
!        the y axis values for the spectrum plot.
!     real ymiss
!        a dummy variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','v',' ',' '/

  option(4) = .false.
  option(3) = .true.
  option(2) = .false.
  option(1) = .false.

  ldstak = 0
  ldsmin = 0

  ymiss = 1.0e0
  lacov = lagmax+1

  ispcf = 101
  ly = 1
  lnlppa = 1
  lpcv = 106
  lwork = 101
  nf = 101
!
!  set number of lag window truncation points
!
  nw = 4
!
!  call the controlling routine for Fourier spectrum routines
!
  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)

  if (ierr == 0) return

  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
    '       call ufsv (acov, lagmax, n)')
end
subroutine ufsvs ( acov, lagmax, n, nw, lags, nf, &
  fmin, fmax, nprt, spcf, ispcf, freq, ldstak )

!*****************************************************************************80
!
!! UFSVS: Fourier spectrum analysis and user supplied acvf values (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     fmax,fmin
  integer &
     ispcf,lagmax,ldstak,n,nf,nprt,nw
!
!  array arguments
  real &
     acov(*),freq(*),spcf(*)
  integer &
     lags(*)
!
!  scalars in common
  integer &
     ierr
!
!  arrays in common
  double precision dstak(12)

  real &
     alpha,delta,ymiss
  integer &
     ifp,io,isort,isym,lacov,ldsmin,lnlppa,lpcv,lwork,ly, &
     nall0,work,xaxis,yaxis
!
!  local arrays
  real &
     rstak(12),y(1)
  integer &
     istak(12),nlppa(1)
  logical &
     option(4)
  character &
     nmsub(6)*1
!
!  external functions
  integer &
     stkget,stkst
  external stkget,stkst
!
!  external subroutines
  external ldscmp,parzen,stkclr,stkset,ufsdrv
!
!  common blocks
  common /cstak/dstak
  common /errchk/ierr
!
!  equivalences
  equivalence (dstak(1),rstak(1))
  equivalence (dstak(1),istak(1))
!
!     variable definitions (alphabetically)
!
!     real acov(lagmax+1)
!        the autocovariances of the series.
!     real alpha
!        the desired confidence level.
!     real delta
!        the sampling interval.
!     double precision dstak(12)
!        the double precision version of the /cstak/ work area.
!     real fmax, fmin
!        the maximum and minimum frequency at which the spectrum
!        is to be computed.
!     real freq(nf)
!        the vector of frequencies at which the spectrum is to be
!        computed.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if err01, no errors were detected
!        if ierr == 1, errors have been detected
!     integer ifp
!        an indicator for stack allocation type, where ifp=3 indicates
!        real and ifp=4 indicates double precision.
!     integer io
!        a variable used to determine the amount of storage required
!        based on printed output requested.
!     integer isort
!        the starting location for the array used for sorting.
!     integer ispcf
!         the actual first dimension of the spectrum arrays.
!     integer istak(12)
!        the integer version of the /cstak/ work area.
!     integer isym
!        the starting location in the work area for array isym.
!     integer lacov
!        the length of the acvf vectors.
!     integer lagmax
!        the maximum lag value to be used.
!     integer lags(nw)
!        the array used to specify the lag window truncation
!        points used for each set of spectrum values.
!     integer ldsmin
!        the minimum length allowed for dstak.
!     integer ldstak
!        the length of the vector dstak in common cstak.
!     integer lnlppa
!        the length of the vector nlppa.
!     integer lpcv
!        the length of the vectors used for plotting.
!     integer lwork
!        the length of the vector w.
!     integer ly
!        the length of the vector y.
!     integer n
!        the integer number of observations in the series.
!     integer nall0
!        the number of allocations outstanding at the time that
!        this routine was called.
!     integer nf
!        the number of frequencies at which the spectrum is
!        to be computed.
!     integer nlppa(1)
!        a dummy array for series without missing values.
!     character*1 nmsub(6)
!        the array containing the name of this subroutine.
!     integer nprt
!        a code used to specify the type of plot, where if
!        nprt < 0 the plot is decibels/linear
!        nprt = 0 the plot is suppressed
!        nprt > 0 the plot is log/linear
!     integer nw
!        the variable used to determine the number of different
!        bandwidths to be used.
!     logical option(4)
!        an indicator array used to designate whether any of the
!        four possible options (f, m, v, or s) have been used (true)
!        or not (false).
!     external parzen
!        the subroutine used to compute the window.
!     real rstak(12)
!        the real version of the /cstak/ work area.
!     real spcf(ispcf,nw)
!        the arrays in which the spectrum is stored
!        for each lag window.
!     integer work
!        the starting location in rstak for
!        the work vector.
!     integer xaxis
!        the starting location in the work area for array xaxis.
!     real y(1)
!        a dummy array.
!     integer yaxis
!        the starting location in the work area for array yaxis.
!     real ymiss
!        a dummy variable.
!
!     set up name arrays
!
  data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / &
     'u','f','s','v','s',' '/

  option(4) = .true.
  option(3) = .true.
  option(2) = .false.
  option(1) = .false.

  lacov = lagmax + 1
!
!  Compute minimum allowable stack length
!
  io = 1
  if (nprt == 0) io = 0

  call ldscmp(4, 0, io*(nf+5), 0, 0, 0, 's', &
     lagmax+1+io*(2*nf+10), ldsmin)

  ymiss = 1.0e0

  ly = 1
  lnlppa = 1
  lpcv = nf + 5
  lwork = lagmax+1
!
!  Set size of work area.
!  Set the number of outstanding allocations.
!  Set the stack allocation type.
!
  call stkset(ldstak, 4)
  nall0 = stkst(1)

  ifp = 3
!
!  Set starting locations in the work area for various arrays.
!
  if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then
     work = 1
     xaxis = 1
     yaxis = 1
     isym = 1
     isort = 1
  else
     work = stkget(lwork,ifp)
     if (nprt /= 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
!
!  Call the controlling routine for Fourier spectrum routines
!
  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)

  call stkclr(nall0)

  if (ierr == 0) return

  write ( *,1000)
  return

 1000 format (/' the correct form of the call statement is'// &
     '       call ufsvs (acov, lagmax, n,'/ &
     '      +            nw, lags, nf, fmin, fmax, nprt,'/ &
     '      +            spcf, ispcf, freq, ldstak)')
end
function v2norm ( p, x )

!***********************************************************************
!
!! V2NORM computes the L2 norm of a vector.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer P, the length of the vector.
!
!    Input, real X(P), the vector.
!
!    Output, real V2NORM, the Euclidean norm of the vector.
!
!  Local Parameters:
!
!    SQTETA is (slightly larger than) the square root of the
!    smallest positive floating point number on the machine.
!    The tests involving SQTETA are done to prevent underflows.
!
  implicit none

  integer p

  integer i
  integer j
  real r
  real scale
  real, save :: sqteta = 0.0E+00
  real t
  real v2norm
  real x(p)
  real xi

  if ( p <= 0 ) then
    v2norm = 0.0E+00
    return
  end if

  i = 0

  do j = 1, p
    if ( x(j) /= 0.0E+00 ) then
      i = j
      exit
    end if
  end do

  if ( i == 0 ) then
    v2norm = 0.0E+00
    return
  end if

  scale = abs ( x(i) )

  t = 1.0E+00

  if ( sqteta == 0.0E+00 ) then
    sqteta = sqrt ( 1.001E+00 * tiny ( sqteta ) )
  end if

  j = i + 1

  do i = j, p

    xi = abs ( x(i) )

    if ( xi <= scale ) then

      r = xi / scale

      if ( sqteta < r ) then
        t = t + r * r
      end if

    else

      r = scale / xi

      if ( sqteta < r ) then
        t = 1.0E+00 + t * r * r
      else
        t = 1.0E+00
      end if

      scale = xi

    end if

  end do

  v2norm = scale * sqrt ( t )

  return
end
subroutine vcopy ( p, y, x )

!***********************************************************************
!
!! VCOPY copies a vector.
!
!  Modified:
!
!    04 April 2006
!
!  Author:
!
!    David Gay
!
!  Parameters:
!
!    Input, integer P, the length of the vector.
!
!    Output, real Y(P), the copy of the input vector.
!
!    Input, real X(P), the vector to be copied.
!
  implicit none

  integer p

  real x(p)
  real y(p)

  y(1:p) = x(1:p)

  return
end
subroutine vcvotf ( npar, vcv, lvcv, est, lmask, mask, ivcvpt )

!*****************************************************************************80
!
!! VCVOTF prints the variance-covariance matrix.
!
!  Discussion:
!
!    this subroutine prints the variance covariance matrix
!    stored row wise when it is to be labelled on the basis of a mask.
!    if est is true, the covariances are listed above the
!    diagonal, the variances on the diagonal, and the correlation
!    coefficients below the diagonal.
!    if est is false, the standard deviations are listed on the
!    diagonal, and the correlation coefficients are below the
!    diagonal.
!
!  Modified:
!
!    25 April 2006
!
!  Author:
!
!    John Koontz,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ivcvpt,lmask,lvcv,npar
  logical &
     est
!
!  array arguments
  real &
     vcv(lvcv)
  integer &
     mask(lmask)
!
!
  integer &
     code,i,ii,mode
!
!     variable definitions (alphabetically)
!
!     integer code
!        if 1 -single printed, x only (y is dummy arg)
!           2 -double printed line, both x and y
!     logical est
!        an indicator used to designate whether the vcv to be printed
!        is of the estimated parameters (true) or not (false).
!     integer i
!        an index variable.
!     integer ii
!        the index of the (i,i)th element of the vcv matrix
!     integer ivcvpt
!        an indicator value used to designate which form of the
!        variance covariance matrix (vcv) is being printed, where
!        ivcvpt = 1 indicates the vcv was computed as
!                   inverse(transpose(jacobian)*jacobian)
!        ivcvpt = 2 indicates the vcv was computed as
!                   inverse(hessian)
!        ivcvpt = 3 indicates the vcv was computed as
!                   inverse(hessian)*transpose(jacobian)*jacobian
!                       *inverse(hessian)
!     integer lmask
!        the length of mask.
!     integer lvcv
!        the length of array vcv.
!     integer mask(lmask)
!        mask vector for vcv.  the index of the ith element of
!        mask equal to zero is the label in the output of vcv
!        of the ith row and ith column.
!     integer mode
!        if 0, lower triangular part printed
!           1, lower triangular part is printed with
!              square roots of the diagonal
!           2, lower triangle printed as correlation matrix
!              with square roots on the diagonal
!           3, full matrix printed
!           4, full matrix printed with correlation matrix
!              printed below the diagonal
!     integer npar
!        the number of unknown parameters in the model.
!     real vcv(lvcv)
!        the variance covariance matrix.
!

  code = 1
!
!  determine whether to issue negative variance warning
!
  mode = 0

  do i = 1, npar

    ii = i*(i-1)/2 + i

    if ( vcv(ii) <= 0.0 ) then

      if ( est ) then
        write ( *,1050)
        if (ivcvpt == 1) write ( *,1060)
        if (ivcvpt == 2) write ( *,1070)
        if (ivcvpt == 3) write ( *,1080)
      else
        write ( *,1000)
      end if

      write ( *,1010)
      call matprf(vcv, vcv, npar, mode, code, lvcv, mask, lmask)
      return

    end if

  end do
!
!  print heading for correlation routines
!
  if ( .not. est ) then

    write ( *,1040)
    write ( *,1030)
    mode = 2
!
!  print heading for estimation routines
!
  else

    write ( *,1050)
    if (ivcvpt == 1) write ( *,1060)
    if (ivcvpt == 2) write ( *,1070)
    if (ivcvpt == 3) write ( *,1080)
    write ( *,1020)
    mode = 4

  end if

  call matprf(vcv, vcv, npar, mode, code, lvcv, mask, lmask)

  return

 1000 format (///' covariance matrix')
 1010 format (/'     nonpositive variances encountered.'/&
    'correlation coefficients cannot be computed.')
 1020 format (4x, '- covariances are above the diagonal'/4x, '- varia', &
     'nces are on the diagonal'/4x, '- correlation coefficients ', &
     'are below the diagonal')
 1030 format (4x, '- standard deviations are on the diagonal'/4x, &
     '- correlation coefficients are below the diagonal')
 1040 format (/' correlation matrix')
 1050 format (///' variance-covariance and correlation matrices', &
     ' of the estimated (unfixed) parameters'/ 1x, 82('-'))
 1060 format (/ &
     4x, '- approximation based on assumption that residuals are', &
     ' small')
 1070 format ( &
     /4x, '- approximation based on asymptotic maximum likelihood theory')
 1080 format (/4x, &
     '- approximation based on assumption that conditions necessary'/ &
     5x, ' for asymptotic maximum likelihood theory', &
     ' might be violated')
end
subroutine vcvout ( np, vcv, ivcv, est )

!*****************************************************************************80
!
!! VCVOUT prints the variance-covariance matrix.
!
!  Discussion:
!
!    this subroutine prints the variance covariance matrix.
!    if est is true, the covariances are listed above the
!    diagonal, the variances on the diagonal, and the correlation
!    coefficients below the diagonal.
!    if est is false, the standard deviations are listed on the
!    diagonal, and the correlation coefficients are below the
!    diagonal.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ivcv,np
  logical &
     est
!
!  array arguments
  real &
     vcv(ivcv,np)

  real &
     den,svcvii,svcvjj
  integer &
     i,j,k,mode
!
!  external subroutines
  external matprt
!
!     variable definitions (alphabetically)
!
!     real den
!        denominator of (i, j) correlation coefficient
!     logical est
!        an indicator used to designate whether the vcv to be printed
!        is of the estimated parameters (true) or not (false).
!     integer i
!        an index variable.
!     integer ivcv
!        the exact first dimension of the matrix vcv.
!     integer j
!        the index of the parameter being examined.
!     integer k
!        an index variable.
!     integer mode
!        if mode is 1, print full matrix.
!        if mode is 2, print lower triangle with square roots of
!                      of the diagonal.
!     integer np
!        the number of unknown parameters in the model.
!     real svcvii, svcvjj
!        square roots of vcv(i, i) and vcv(j, j)
!     real vcv(ivcv,np)
!        the variance covariance matrix.
!

!
!  determine whether to issue negative variance warning
!
  mode = 2
  do i=1,np
    if ( vcv(i,i) <= 0.0 ) then
      write ( *,1000)
      if (est) write ( *,1050)
      write ( *,1010)
      mode = 0
      go to 70
    end if
  end do

  if (est) go to 20
!
!  print heading for correlation routines
!
  write ( *,1040)
  write ( *,1030)
  mode = 2
  go to 30

   20 continue
!
!  print heading for estimation routines
!
  write ( *,1050)
  write ( *,1020)
  mode = 1

   30 continue
!
!  compute the correlation coefficients and store in the bottom half
!  of the variance covariance matrix
!
  do j=2,np

     k = j - 1
     svcvjj = 0.0e0
     if (vcv(j,j) > 0.0e0) svcvjj = sqrt(vcv(j,j))

     do i=1,k
        svcvii = 0.0e0
        if (vcv(i,i) > 0.0e0) svcvii = sqrt(vcv(i,i))
        den = svcvii*svcvjj
        if (den <= 0.0e0) vcv(j,i) = 0.0e0
        if (den > 0.0e0) vcv(j,i) = vcv(j,i)/den
     end do

  end do

   70 continue

  call matprt(vcv, vcv, np, mode, 1, ivcv)
!
!  restore the vcv matrix
!
  if (np == 1) return
  do j=2,np
     k = j - 1
     vcv(j,1:k) = vcv(1:k,j)
  end do

  return

 1000 format (/' covariance matrix')
 1010 format (/'     nonpositive variances encountered.'/&
    'correlation coefficients cannot be computed.')
 1020 format (4x, '- covariances are above the diagonal'/4x, '- varia', &
     'nces are on the diagonal'/4x, '- correlation coefficients ', &
     'are below the diagonal')
 1030 format (4x, '- standard deviations are on the diagonal'/4x, &
     '- correlation coefficients are below the diagonal')
 1040 format (/' correlation matrix')
 1050 format (/' variance-covariance and correlation matrices', &
     ' of the estimated parameters'/ 1x, 72('-')/)
end
subroutine versp ( wide )

!*****************************************************************************80
!
!! VERSP prints the version number.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  logical &
     wide
!
!     variable definitions (alphabetically)
!
!     logical wide
!        the maximum number of columns the printed output can use.
!
  if (wide) then
     write ( *, 1000)
  else
     write ( *, 1010)
  end if

  return

 1000 format (105x, 'starpac 2.08s (03/15/90)')
 1010 format (54x, 'starpac 2.08s (03/15/90)')
end
subroutine vp ( ym, n, ns )

!*****************************************************************************80
!
!! VP is the user callable routine which produces a vertical plot (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     n,ns
!
!  array arguments
  real &
     ym(*)
!
!  scalars in common
  integer &
     ierr

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  ' ',       'v',       'p',       ' ',       ' ',       ' '/

  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

  call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
     '       call vp (y, n, ns)')
end
subroutine vpc ( ym, n, ns, ilog, isize, irlin, ibar, ylb, yub, xlb, xinc )

!*****************************************************************************80
!
!! VPC is the user callable routine which produces a vertical plot (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,isize,n,ns
!
!  array arguments
  real &
     ym(*)
!
!  scalars in common
  integer &
     ierr

  integer ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  ' ',       'v',       'p',       'c',       ' ',       ' '/

  ymmiss(1) = 1.0e0
  m = 1
  iym = n
  multi = .false.
  ischck = 0
  miss = .false.
  lisym = 1

  call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym )

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' 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 )

!*****************************************************************************80
!
!! VPCNT is the controlling routine for user-called vertical plots
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     logical error
!        a value indicating whether an error was detectec (true)
!        or not (false).
!     integer ibar
!        the indicator used to designate whether the plot is to be a
!        bar graph (ibar >= 1) or not (ibar <= 0).
!     integer ierr
!        the common variable used to indicate errors,
!        if =0, then no errors
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator used to designate whether the plot will have
!        the location of zero plotted as a reference line (irlin == 0),
!        the location of the mean plotted as a reference line (irlin >= 
!        or no reference line (irlin<0).
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(lisym)
!        vector containing symbols for plotting, not used in some cases
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns, nsampl
!        the sampling frequency.
!     logical xcheck
!        indicator variable used to designate whether x-axis values
!        are to be checked (xcheck = .true.) or not (xcheck = .false.)
!     real xinc
!        the increment for the x-axis.
!     real xlb
!        the lower bound for the x-axis.  (xlb=xub indicates limits are
!        to be determined from the range of the data.)
!     real ylb
!        the lower bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!     real ym(iym,m)
!        multivariate observations for the y coordinates
!     real ymmiss(m)
!        the missing value code for the y-axis.
!     real ymn, ymx
!        the y-ayis lower and upper limits actually used.
!     real yub
!        the upper bound for the y-axis.  (ylb=yub indicates limits are
!        to be determined from the range of the data.)
!
  implicit none

  integer ibar
  integer ilog
  integer irlin
  integer ischck
  integer isize
  integer iym
  integer lisym
  integer m
  integer n
  integer ns
  real xinc
  real xlb
  real ylb
  real yub

  logical &
     miss,multi
!
!  array arguments
  real &
     ym(*),ymmiss(*)
  integer &
     isym(*)
  character &
     nmsub(6)*1
!
!  scalars in common
  integer &
     ierr

  real &
     ymn,ymx
  integer &
     nsampl
  logical &
     error,xcheck
!
!  common blocks
  common /errchk/ierr

  xcheck = .false.

  call pltchk ( ym, ymmiss, ym, ymmiss, n, m, iym, multi, &
     ilog, ylb, yub, xlb, xinc, nmsub, miss, xcheck )

  if ( ierr == 0 ) then
!
!  Determine the bounds for the axis and complete error checking
!
    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
!
!  Print plot
!
      if ( mod ( max ( 0, isize ), 10 ) == 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 )

    end if

  end if

  return
end
subroutine vphead ( nsampl, irlin, ibar, ywidth, ymn, ymx, &
  isize, ilog, line, numcol, ilogy, ydmn, ydmx )

!*****************************************************************************80
!
!! VPHEAD prints the heading for the vertical plot output.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     real dely
!        the scale interval of the plot.
!     integer i
!        an indexing variable.
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ilogy
!        the value of q (see ilog)
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer nsampl
!        the sampling frequency,
!        where if nsampl <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real ydmn, ydmx
!        the y-axis data limits actually used.
!     real ylabel(20)
!        the y-axis lables.
!     character ylfmt*205, ylfmt2*205
!        the formats used to print the x-axis
!     real ymn, ymx
!        the graph axis lower and upper limits actually used.
!
  implicit none

  real ydmn,ydmx,ymn,ymx,ywidth
  integer &
     ibar,ilog,ilogy,irlin,isize,nsampl,numcol
!
!  array arguments
  character &
     line(103)*1

  real &
     dely
  integer &
     i,icol,ik,jcol,nlably,nlu
  character &
     fmt*4,ylfmt*205,ylfmt2*205
!
!  local arrays
  real &
     ylabel(20)
  integer &
     ispace(20)

!
!  check plot sequence.
!
  if (nsampl == 2) then
     write ( *, 1003)
  else if (nsampl == 3) then
     write ( *, 1004)
  else if (nsampl >= 4) then
     write ( *, 1005) nsampl
  end if
!
!  print headings for y
!
  if (ibar == 0) then
     if (irlin >= 1) then
        write ( *, 1006)
     else if (irlin == 0) then
        write ( *, 1007)
     end if
  end if
!
!  find size of plot to be created
!
  if (mod(max(0,isize),10) == 0) then
    numcol=101
  else
    numcol = 51
  end if
!
!  adjust for log plots if necessary and find axis labels
!
  call prtcnt (mod(max(0,ilog),10),1,ilogy)
  call loglmt (ilogy, ymn, ymx, ylabel, numcol, 10, dely, ywidth, &
    nlably, ydmn, ydmx)
!
!  write out the horizontal axis and the axis labels.
!
  line(1:numcol)='-'
  line(1)='i'

  if (ilogy == 0) then

    nlu = nlably+1
    do icol=numcol,1,-10
       line(icol)='i'
       nlu = nlu - 1
       ispace(nlu) = 1
    end do

  else

    jcol = 1
    line(jcol) = 'i'
    nlu = nlably
    do ik = nlably,1,-1
      icol = int ( ((log10(ylabel(ik))-ymn)/ywidth)+1.5e0 )
      line(icol) = 'i'
      if (icol-jcol >= 10) then
        ispace(nlu) = icol-jcol-9
        nlu = nlu - 1
        ylabel(nlu) = ylabel(ik)
        jcol = icol
      end if
    end do
  end if

  line(numcol+1)='-'
  line(numcol+2)=' '
!
!  check x-axis labels for format
!
  fmt = 'f9.4'
  do i=1,nlably
     if (((abs(ylabel(i)) > 0.0e0).and. &
          (abs(ylabel(i))<0.01e0)) .or. &
         ((ylabel(i) >= 1.0e4).or.(ylabel(i) <= (-1.0e3)))) then
       fmt = 'e9.3'
       exit
     end if
  end do

  write(ylfmt2,1000) nlably-nlu
  write(ylfmt,ylfmt2) (fmt, ispace(i), i=nlably,nlu+1,-1), fmt
  write ( *, ylfmt) (ylabel(i),i=nlably,nlu,-1)

  write ( *, 1001) '-', (line(icol), icol=1,numcol+2)

  return

 1000 format ('(''(11x'',', i2, '('', '', a4, '','', i2, ''x''),', &
    ''', '', a4, '')'')')
 1001 format (' ',13x, a1, 105a1)
 1003 format('0note that every other point has been plotted')
 1004 format('0note that every third point has been plotted')
 1005 format('0note that every ', i2, 'th 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
subroutine vpl ( ym, n, ns, ilog )

!*****************************************************************************80
!
!! VPL is the user callable routine which produces a vertical log plot.
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer &
     ilog,n,ns
!
!  array arguments
  real &
     ym(*)
!
!  scalars in common
  integer &
     ierr

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  real &
     ymmiss(1)
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  ' ',       'v',       'p',       'l',       ' ',       ' '/

  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

  call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym)

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if
  return

 1000 format (/' 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 )

!*****************************************************************************80
!
!! VPLMT sets the plot limits for vertical plots
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     ylb,ymn,ymx,yub
  integer &
     iym,m,n,nsampl
  logical &
     error,miss
!
!  array arguments
  real &
     ym(iym,m),ymmiss(m)
  character &
     nmsub(6)*1
!
!
  integer &
     i,ii,j
  logical &
     head,setlmt
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!     variable definitions (alphabetically)
!
!     logical error
!        a value indicating whether an error was detected (true)
!        or not (false).
!     logical head
!        print heading (head=true) or not (head=false).
!     integer i, ii
!        indexing variables.
!     integer iym
!        actual row dimension of ym declared in the users main program
!     integer j
!        an index variable.
!     integer m
!        the number of vectors in ym
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     integer n
!        the integer number of observations .
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer nsampl
!        *
!     logical setlmt
!        an indicator variable used to determine if starting values
!        for xlb, xinc, ymn, ymx have been found.
!     real ylb
!        the user supplied y-axis lower bound.
!     real ym(iym,m)
!        the array containing the dependent variable(s).
!     real ymmiss(m)
!        the user supplied code which is used to determine whether or
!        not an observation is missing.
!        if ym(i,j) = ymmiss(j), the value is assumed missing, otherwise
!        it is not.
!     real ymn, ymx
!        the y-axis lower and upper limits actually used.
!     real yub
!        the user supplied y-axis upper bounds.
!
  error = .false.
!
!  Set limits to user specified values
!
  if (ylb<yub) then

    ymn = ylb
    ymx = yub
!
!  Set limits to range of values within any user specified values
!
  else

    setlmt = .false.
    ii = 1
    ymn =  huge ( ymn )
    ymx = -huge ( ymx )
!
!  Find first value to be plotted.
!
    do i=1,n,nsampl

       do j=1,m

          if ( miss .and. mvchk(ym(i,j),ymmiss(j)) ) then
            cycle
          end if

          if ((ylb < yub) .and. ((ym(i,j) < ylb) .or. &
             (yub < ym(i,j)))) then
            cycle
          end if

          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

      end do

       if (setlmt) then
         exit
      end if

  end do
!
!  no values to be plotted.  print error message
!
  if (ii <= 1) then

      error = .true.
      head = .true.
      call ehdr(nmsub,head)
      if (ylb >= yub) then
        write ( *, 1010)
      else
        write ( *, 1020)
      end if
      write ( *, 1030)
!
!  find limits from remaining values
!
    else

      if (ii <= n) then

        do i=ii,n,nsampl
           do j=1,m

              if (miss .and. mvchk(ym(i,j),ymmiss(j))) then
                cycle
              end if

              if ((ylb<yub) .and. ((ym(i,j)<ylb) .or. &
                 (yub<ym(i,j)))) then
                cycle
              end if

              ymn = min(ymn, ym(i,j))
              ymx = max(ymx, ym(i,j))
           end do
        end do

      end if
    end if
!
!  adjust y axis limits if equal
!
    if (ymn  >=  ymx) then
      call adjlmt(ymn, ymx)
    end if

  end if

  return

 1010 format (/ &
     ' no non-missing plot coordinates were found.')
 1020 format (/ &
     ' no non-missing values were found within', &
     ' the user supplied limits.')
 1030 format (/ ' the plot has been suppressed.')
end
subroutine vpm ( ym, ymmiss, n, ns )

!*****************************************************************************80
!
!! VPM produces a vertical plot with missing data (short call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
  implicit none

  integer &
     n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(1)
!
!  scalars in common
  integer &
     ierr

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  ' ',       'v',       'p',       'm',       ' ',       ' '/

  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

  call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym )

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call vpm (y, ymiss, n, ns)')
end
subroutine vpmc ( ym, ymmiss, n, ns, ilog, isize, &
  irlin, ibar, ylb, yub, xlb, xinc )

!*****************************************************************************80
!
!! VPMC produces a vertical plot with missing data (long call).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,ilog,irlin,isize,n,ns
!
!  array arguments
  real &
     ym(*),ymmiss(1)
!
!  scalars in common
  integer &
     ierr
!
!
  integer ischck,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  ' ',       'v',       'p',       'm',       'c',       ' '/

  m = 1
  iym = n
  multi = .false.
  ischck = 0
  miss = .true.
  lisym = 1

  call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym )

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if
  return

 1000 format (/' the correct form of the call statement is'// &
    '       call vpmc (y, ymiss, n, ns, ilog,'/ &
    '      +           isize, irlin, ibar, ylb, yub, xlb, xinc)')
end
subroutine vpml ( ym, ymmiss, n, ns, ilog )

!*****************************************************************************80
!
!! VPML produces a vertical plot with missing data (log plot option).
!
!  Modified:
!
!    26 April 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
  implicit none

  integer ilog
  integer n
  integer ns
!
!  array arguments
  real &
     ym(*),ymmiss(1)
!
!  scalars in common
  integer &
     ierr
!
!
  real &
     xinc,xlb,ylb,yub
  integer &
     ibar,irlin,ischck,isize,iym,lisym,m
  logical &
     miss,multi
!
!  local arrays
  integer &
     isym(1)
  character &
     nmsub(6)*1
!
!  external subroutines
  external vpcnt
!
!  common blocks
  common /errchk/ierr
!
!     variable definitions (alphabetically)
!
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     integer ierr
!        a common variable used as a flag to indicate whether
!        or not there are any errors, if =0 then no errors.
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(1)
!        vector containing symbol designations for plotting
!     integer iym
!        the first dimension of array ym.
!     integer lisym
!        the length of array isym.
!     integer m
!        number of y vectors
!     logical miss
!        indicator variable used to designate whether missing values
!        may be present (miss = .true.) or not (miss = .false.)
!     logical multi
!        indicator variable used to designate whether multiple y values
!        are to be plotted (multi = .true.) or not (multi = .false.)
!     integer n
!        length of vectors
!     character*1 nmsub(6)
!        the characters of the calling routines name.
!     integer ns
!        the sampling frequency,
!        where if ns <= 1, every point is plotted,
!                       = 2, every other point is plotted,
!                       = 3, every third point is plotted, etc.
!     real xinc, xlb
!        increment and lower bounds for x-axis.
!     real ylb
!        lower bound for y-axis.
!     real ym(n,1)
!        multivariate observations for the y coordinates
!     real ymmiss(1)
!        the missing value code for the y-axis.
!     real yub
!        upper bound for y-axis.
!
!     set up name arrays
!
  data &
    nmsub(1),  nmsub(2),  nmsub(3),  nmsub(4),  nmsub(5),  nmsub(6) &
      /  ' ',       'v',       'p',       'm',       'l',       ' '/

  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

  call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, &
    xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, &
    miss, lisym )

  if (ierr /= 0) then
    ierr = 1
    write ( *,1000)
  end if

  return

 1000 format (/' the correct form of the call statement is'// &
    '       call vpml (y, ymiss, n, ns, ilog)')
end
subroutine vpmn ( ym, ymmiss, n, m, iym, nsampl, ischck, isym, &
  lisym, isize, ymn, ymx, xlb, xinc, miss, ilog, irlin, ibar )

!*****************************************************************************80
!
!! VPMN produces vertical plots.
!
!  Modified:
!
!    02 December 2006
!
!  Author:
!
!    Janet Donaldson,
!    Statistical Engineering Division,
!    National Bureau of Standards,
!    Boulder, Colorado
!
!  Parameters:
!
!     character fmt*72
!        the format for the x-axis labels
!     integer i
!        an indexing variable.
!     integer ibar
!        the variable used to determine if single points (ibar == 0)
!        or bars (ibar  /=  0) are to be plotted.
!     character*1 iblank
!        the plot symbol blank.
!     integer icount(103)
!        the number of plot symbols at each location.
!     integer iend
!        the number of locations in the plot string.
!     integer ierr
!        the integer value returned by this routine designating
!        whether any errors were detected in the parameter list
!        if ierr == 0, no errors were detected
!        if ierr == 1, errors have been detected
!     logical ifmiss
!        the indicator variable used to determine whether the
!        input series has missing data (true) or not (false).
!     integer ilog
!        the two digit integer, pq, used to select axis scale, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is linear.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is log.
!     integer ilogy
!        the value of q (see ilog).
!     character*1 im
!        the plot symbol m.
!     integer imax
!        the largest location in the plot string being defined.
!     integer imin
!        the smallest location in the plot string being defined.
!     character*1 ipltch
!        the plot character used for a given line of the plot.
!     integer ipoint
!        the location in the plot string of the value being plotted.
!     integer iptsym
!        an indicator variable used to designate the type
!        of plot.  if ischck = 1, the plot is a symple page
!        or vertical plot.  if ischck = 2, the plot is a symbol
!        plot.  if ischck = 3, the plot is a multivariate plot.
!     character*1 irefch
!        the plot symbol used to identify the plot reference line.
!     integer irefpt
!        the location in the plot string for the value zero, or
!        series mean, which ever was requested.
!     integer irlin
!        the indicator variable used to designate whether zero or the
!        series mean is to be plotted as a reference line, or whether
!        no reference line is to be plotted.
!        if irlin <= -1, no reference line is plotted.
!        if irlin ==  0, zero is plotted as the reference line.
!        if irlin  >=   1, the series mean is plotted.
!     integer ischck
!        the integer value indicating how the plotting symbols
!           will be designated, where
!           0 indicates the plotting symbols have not been designated in
!             the n vector isym and only the symbol + is to be used
!           1 indicates the plotting symbols have been designated in the
!             n vector isym
!           2 indicates that m series are being plotted.
!             symbol i+4 will be used for column i of ym.
!     integer isize
!        the two digit integer, pq, used to select axis size, where
!        p designates the x-axis and q designates the y-axis.
!        if p == 0 (q == 0), then the x-axis (y-axis) is the maximum.
!        if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu
!     integer isym(lisym)
!        vector containing symbol designations for plotting
!     integer iym
!        the exact value of the first dimension of the matrix ym.
!     character*1 i0
!        the plot symbol -0-.
!     integer j
!        an index variable.
!     character*1 line(103)
!        the vector used for the plot string.
!     integer m
!        the number of columns of data in ym.
!     integer n
!        the integer number of observations .
!     integer nsampl
!        the sampling frequency actually used.
!     integer nused
!        the number of active observations.
!     real refpt
!        the value zero, or the mean of the series, which ever is
!        requested, used as a plot reference line.
!     real xinc
!        the variable used to specify the increment for xlabel.
!     real xlabel
!        the value used for the labels on the right side of the plot.
!     real xlb
!        the starting value for labels on the right side of the graph.
!     real ydmn, ydmx
!        the y-axis data limits actually used.
!     real ym(iym,m)
!        the vector containing the observed time series
!     real ymmiss(m)
!        the user supplied code which is used to determine whether or
!        not an observation in the series is missing.  if ym(i) = ymmiss
!        the value is assumed missing, otherwise it is not.
!     real ymn, ymx
!        the graph axis lower and upper limits actually used.
!     real ywidth
!        the scale interval of the plot.
!     real yy
!        the value of ym actually being plotted
!
  implicit none

  integer ibar
  integer ilog
  integer irlin
  logical miss
  real xinc
  real xlb
  real ymn
  real ymx

  integer &
     ischck,isize,iym,lisym,m,n,nsampl
!
!  array arguments
  real &
     ym(iym,m),ymmiss(m)
  integer &
     isym(lisym)
!
!  scalars in common
  integer &
     ierr

  real &
     refpt,xlabel,ydmn,ydmx,ywidth,yy
  integer &
     i,iend,ilogy,imax,imin,ipoint,iptsym,irefpt,j,numcol, &
     nused
  logical &
     ifmiss
  character &
     i0*1,iblank*1,im*1,ipltch*1,irefch*1,fmt*72
!
!  local arrays
  integer &
     icount(103)
  character &
     line(103)*1
!
!  external functions
  logical &
     mvchk
  external mvchk
!
!  common blocks
  common /errchk/ierr

  data iblank/' '/, im/'m'/, i0/'0'/
!
!  print plot headings
!
  call vphead ( nsampl, irlin, ibar, ywidth, ymn, ymx, isize, ilog, &
    line, numcol, ilogy, ydmn, ydmx )

  iend = numcol + 2
!
!  Compute reference point of graph, if required.
!
  if ( 0 <= irlin ) then
!
!  reference point is zero
!
    if ( irlin == 0 ) then

      refpt = 0.0e0
      irefch = i0
!
!  reference point is mean
!
    else

      if ( miss ) then
        call ameanm ( ym, ymmiss, n, nused, refpt )
      else
        call amean ( ym, n, refpt )
      end if

      if (ilogy /= 0) refpt = log10(refpt)

      irefch = im

    end if
!
!  Compute location of refpt in plot string
!
    call pltplx ( refpt, ymn, ywidth, irefpt, iend )

  else

    irefpt = 1

  end if
!
!  Begin plotting
!
  iptsym = ischck + 1
  xlabel = xlb

  do i = 1, n, nsampl

     call pline ( 1, iend, iblank, line )
     call setiv ( icount, iend, 0 )
     ifmiss = .false.
     ipoint = 1

     do 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 == 0) then
             yy = ym(i,j)
           else
             yy = log10(ym(i,j))
           end if

           if ((yy >= ydmn) .and. (yy <= 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 == 0) then
           yy = ym(i,j)
         else
           yy = log10(ym(i,j))
         end if

         if ((yy >= ydmn) .and. (yy <= 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

     end do

     if ((ibar >= 1) .and. (.not.ifmiss)) then
        imin = min(ipoint,irefpt)
        imax = max(ipoint,irefpt)
        call pline(imin, imax, ipltch, line)
     else if (irlin >= 0) then
        line(irefpt) = irefch
     end if

     if ( ifmiss ) then
       write ( fmt, 1001 ) numcol
       write ( *,fmt) xlabel, (line(j), j=1,iend)
     else
       write(fmt,1000) numcol, 'g12.5'
       if (m == 1) then
         write ( *,fmt) xlabel, (line(j),j=1,iend), ym(i,1)
       else
         write ( *,fmt) xlabel, (line(j),j=1,iend)
       end if
     end if

     xlabel = xlabel + xinc * real ( nsampl )

  end do

  return

 1000 format( '(g12.5,1x,a1,''i'',', i3, 'a1,''i'',a1,',a, ')' )
 1001 format( '(g12.5,1x,a1,''i'',', i3, 'a1,''i'',a1, ''Missing''  )' )
end
subroutine xerabt ( messg, nmessg )

!*****************************************************************************80
!
!! XERABT aborts program execution and prints an error message.
!
!  Discussion:
!
!    This routine is called to abort execution of a running program,
!    indicated by the occurrence of a fatal error.
!
!    The error message associated with the fatal condition is provided
!    in the calling sequence.
!
!    This routine is used when the error message handlers XERROR and
!    XERRWV are employed.  The similar routine XERHLT is to be used 
!    when the more modern error message handler XERMSG is used.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) MESSG, the message to be processed.
!
!    Input, integer NMESSG, the actual number of characters in MESSG.
!    If NMESSG is 0, no message is being supplied.
!
  implicit none

  character ( len = * ) messg
  integer nmessg

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'XERABT - Termination after fatal error!'

  if ( 0 < len ( messg ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Associated error message:'
    write ( *, '(a)' ) '"' // trim ( messg ) // '"'
  end if

  stop
end
subroutine xerbla ( subrou, nerr )

!*****************************************************************************80
!
!! XERBLA is an error handler for the Level 2 and Level 3 BLAS routines.
!
!  Discussion:
!
!    This routine is called by Level 2 and 3 BLAS routines if an input 
!    parameter is invalid.
!
!  Modified:
!
!    06 April 2007
!
!  Parameters:
!
!    Input, character ( len = * ) SUBROU, the name of the routine which
!    called XERBLA.  The name will not be more than 6 characters.
!
!    Input, integer NERR, the error number, which here is used to
!    indicate the position of the invalid parameter in the 
!    parameter-list of the calling routine.
!
  implicit none

  integer level
  character ( len = 6 ) librar
  character ( len = 60 ) message
  integer nerr
  character ( len = * ) subrou

  librar = 'SLATEC'
  write ( message, '(a,a,a,i2,a)' ) 'On entry to ', trim ( subrou ), &
    ', parameter number ', nerr, ' had an illegal value.'
  level = 1

  call xermsg ( librar, subrou, message, nerr, level )

  return
end
subroutine xerclr ( )

!*****************************************************************************80
!
!! XERCLR resets the current error number to zero.
!
!  Discussion:
!
!    This routine simply resets the current error number to zero.
!
!    This may be necessary to do in order to determine that
!    a certain error has occurred again since the last time
!    NUMXER was referenced.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    None
!
  implicit none

  integer j4save
  integer junk
  logical set
  integer value
  integer which

  which = 1
  value = 0
  set = .true.

  junk = j4save ( which, value, set )

  if ( junk == 1952 ) then
    write ( *, '(a)' ) 'This is a dummy message!'
  end if

  return
end
subroutine xercnt ( librar, subrou, messg, nerr, level, kontrl )

!*****************************************************************************80
!
!! XERCNT allows user control over the handling of errors.
!
!  Description:
!
!    This routine allows user control over handling of individual errors.
!
!    This routine is to be used when the error message routine XERMSG
!    is employed.  The similar routine XERCTL is to be used for the
!    older error message routines XERROR and XERRWV.
!
!    Just after each message is recorded, but before it is
!    processed any further (i.e., before it is printed or
!    a decision to abort is made), a call is made to XERCNT.
!
!    If the user has replaced this default, dummy version of XERCNT
!    with a customized routine, it can then be used to override the 
!    value of KONTROL used in processing this message by redefining its value.
!
!    KONTRL may be set to any value from -2 to 2.
!
!    The meanings for KONTRL are the same as in XSETF, except
!    that the value of KONTRL changes only for this message.
!
!    If KONTRL is set to a value outside the range from -2 to 2,
!    it will be moved back into that range.
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) LIBRAR, the library or software package
!    from which the error message is coming.
!
!    Input, character ( len = * ) SUBROU, the subroutine or function within
!    the library, from which the error message is coming.
!
!    Input, character ( len = * ) MESSG, the error message.
!
!    Input, integer NERR, the error number.
!
!    Input, integer LEVEL, the error severity level.
!    * 2, this is an unconditionally fatal error.
!    * 1, this is a recoverable error.  It is normally non-fatal, unless
!         KONTRL has been reset by XSETF.
!    * 0, this is a warning message only.
!    *-1, this is a warning message which is to be printed at most once, 
!         regardless of how many times this call is executed.
!
!    Input/output, integer KONTRL.  This routine receives the current
!    value of KONTRL, and may reset it.  The change is effective only
!    for the current error message.  This allows the user to suppress
!    or force printing of certain messages, for instance.
!
  implicit none

  integer kontrl
  integer level
  character ( len = * ) librar
  character ( len = * ) messg
  integer nerr
  character ( len = * ) subrou

  return
end
subroutine xerctl ( messg, nmessg, nerr, level, kontrl )

!*****************************************************************************80
!
!! XERCTL allows user control over handling of individual errors.
!
!  Discussion:
!
!    This routine gives the user control over handling of individual errors.
!
!    This routine is to be used when the error message routines XERROR
!    and XERRWV are used.  The similar routine XERCNT is to be used for 
!    the newer error message routine XERMSG.
!
!    This routine is called just after each message has been recorded, 
!    but before it is processed any further; that is, before the
!    message is printed or a decision to abort is made.
!
!    If the user wishes to influence the behavior of the error package
!    with respect to certain errors, then this dummy version of the
!    routine should be replaced by a routine that carries out the
!    actions the user desires.
!
!    In particular, the user can override the value of KONTRL used 
!    in processing this message by redefining its value.
!
!    KONTRL may be set to any value from -2 to 2.
!    The meanings for KONTRL are the same as in XSETF, except
!    that the value of KONTRL changes only for this message.
!
!    If KONTRL is set to a value outside the range from -2 to 2,
!    it will be moved back into that range.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) MESSG, the error message.
!
!    Input, integer NMESSG, same as in the call to XERROR or XERRWV.
!
!    Input, integer NERR, same as in the call to XERROR or XERRWV.
!
!    Input, integer LEVEL, same as in the call to XERROR or XERRWV.
!
!    Input/output, integer KONTRL.  On input, the current value of the control 
!    flag as set by a call to XSETF.  On output, the new value of kontrl.  
!    If KONTRL is not defined, it will remain at its original value.
!    This changed value affects only the current occurrence of the current 
!    message.
!
  implicit none

  integer kontrl
  integer level
  character ( len = * ) messg
  integer nerr
  integer nmessg

  return
end
subroutine xerdmp ( )

!*****************************************************************************80
!
!! XERDMP prints the error tables and then clears them.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    None
!
  implicit none

  integer count
  integer level
  character ( len = 1 ) messg
  integer nerr
  integer nmessg
  
  messg = ' '
  nmessg = 0
  nerr = 0
  level = 0
  count = 0

  call xersav ( messg, nmessg, nerr, level, count )

  return
end
subroutine xerhlt ( messg )

!*****************************************************************************80
!
!! XERHLT aborts program execution.
!
!  Discussion:
!
!    This routine aborts the execution of the program.
!
!    The error message causing the abort is given in the calling
!    sequence.
!
!    This routine is used when the error message handler XERMSG is
!    employed.  The similar routine XERABT is to be used when the
!    older error message handlers XERROR and XERRWV are used.
!
!  Modified:
!
!    06 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) MESSG, the error message associated
!    with the halt in execution.
!
  implicit none

  character ( len = * ) messg

  stop
end
subroutine xermax ( maxmes )

!*****************************************************************************80
!
!! XERMAX sets the maximum number of times any error message is to be printed.
!
!  Discussion:
!
!    This routine sets the maximum number of times any error message
!    is to be printed.  That is, a non-fatal message associated with
!    a particular numbered error should not be be printed more than
!    MAXMES times.
!
!    Most error messages won't be printed at all if the error printout
!    suppression mode has been set.  That is the case if the variable
!    KONTRL has been set to zero.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, integer MAXMES, the maximum number of times any one message
!    is to be printed.
!
  implicit none

  integer j4save
  integer junk
  integer maxmes
  logical set
  integer value
  integer which

  which = 4
  value = maxmes
  set = .true.

  junk = j4save ( which, value, set )

  if ( junk == 1952 ) then
    write ( *, '(a)' ) 'This is a dummy message!'
  end if

  return
end
subroutine xermsg ( librar, subrou, messg, nerr, level )

!*****************************************************************************80
!
!! XERMSG processes error messages.
!
!  Description:
!
!    This routine processes a diagnostic message in a manner determined by the
!    value of LEVEL and the current value of the library error control
!    flag, KONTRL.
!
!    See subroutine XSETF for details on KONTRL.
!
!  Modified:
!
!    08 April 2007
!
!  Author:
!
!    Kirby Fong
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) LIBRAR, the name of the library from which the
!    error message was generated. 
!
!    Input, character ( len = * ) SUBROU, the name of the subroutine or function
!    from which the error message was generated.
!
!    Input, character ( len = * ) MESSG, the text of the error or warning 
!    message.  In the example below, the message is a character constant that 
!    contains a generic message.
!
!      call xermsg ('SLATEC', 'MMPY',
!      'The order of the matrix exceeds the row dimension', 3, 1)
!
!    It is possible (and is sometimes desirable) to generate a
!    specific message--e.g., one that contains actual numeric
!    values.  Specific numeric values can be converted into
!    character strings using formatted WRITE statements into
!    character variables.  This is called standard Fortran
!    internal file I/O and is exemplified in the first three
!    lines of the following example.  You can also catenate
!    substrings of characters to construct the error message.
!    Here is an example showing the use of both writing to
!    an internal file and catenating character strings.
!
!      character ( len = 5 ) charn, charl
!      write (charn,'(i5)') n
!      write (charl,'(i5)') lda
!      call xermsg ('SLATEC', 'MMPY', 'The order'//charn//
!      ' of the matrix exceeds its row dimension of'// charl, 3, 1)
!
!    There are two subtleties worth mentioning.  One is that
!    the // for character catenation is used to construct the
!    error message so that no single character constant is
!    continued to the next line.  This avoids confusion as to
!    whether there are trailing blanks at the end of the line.
!    The second is that by catenating the parts of the message
!    as an actual argument rather than encoding the entire
!     message into one large character variable, we avoid
!    having to know how long the message will be in order to
!    declare an adequate length for that large character
!    variable.  XERMSG calls XERPRN to print the message using
!    multiple lines if necessary.  If the message is very long,
!    XERPRN will break it into pieces of 72 characters (as
!    requested by XERMSG) for printing on multiple lines.
!    Also, XERMSG asks XERPRN to prefix each line with ' *  '
!    so that the total line length could be 76 characters.
!    Note also that XERPRN scans the error message backwards
!    to ignore trailing blanks.  Another feature is that
!    the substring '$$' is treated as a new line sentinel
!    by XERPRN.  If you want to construct a multiline
!    message without having to count out multiples of 72
!    characters, just use '$$' as a separator.  '$$'
!    obviously must occur within 72 characters of the
!    start of each line to have its intended effect since
!    XERPRN is asked to wrap around at 72 characters in
!    addition to looking for '$$'.
!
!    Input, integer NERR, the error number, chosen by the library routine's
!    author.  It must be in the range -99 to 999 (three printable digits).  
!    Each distinct error should have its own error number.  These error 
!    numbers should be described in the machine readable documentation 
!    for the routine.  The error numbers need be unique only within each 
!    routine, so it is reasonable for each routine to start enumerating
!    errors from 1 and proceeding to the next integer.
!
!    Input, integer LEVEL, a value in the range 0 to 2 that indicates the
!    level (severity) of the error.  Their meanings are
!    * -1: A warning message.  This is used if it is not clear
!    that there really is an error, but the user's attention
!    may be needed.  An attempt is made to only print this
!    message once.
!    * 0: A warning message.  This is used if it is not clear
!    that there really is an error, but the user's attention
!    may be needed.
!    * 1: A recoverable error.  This is used even if the error is
!    so serious that the routine cannot return any useful
!    answer.  If the user has told the error package to
!    return after recoverable errors, then XERMSG will
!    return to the Library routine which can then return to
!    the user's routine.  The user may also permit the error
!    package to terminate the program upon encountering a
!    recoverable error.
!
!    * 2: A fatal error.  XERMSG will not return to its caller
!    after it receives a fatal error.  This level should
!    hardly ever be used; it is much better to allow the
!    user a chance to recover.  An example of one of the few
!    cases in which it is permissible to declare a level 2
!    error is a reverse communication Library routine that
!    is likely to be called repeatedly until it integrates
!    across some interval.  If there is a serious error in
!    the input such that another step cannot be taken and
!    the Library routine is called again without the input
!    error having been corrected by the caller, the Library
!    routine will probably be called forever with improper
!    input.  In this case, it is reasonable to declare the
!    error to be fatal.
!
  implicit none

  integer i
  integer j4save
  integer kdummy
  integer kount
  integer lerr
  integer level
  character ( len = 20 )  lfirst
  character ( len = * ) librar
  integer lkntrl
  integer llevel
  integer ltemp
  integer maxmes
  character ( len = * ) messg
  integer mkntrl
  integer nerr
  logical set
  logical skip
  character ( len = * ) subrou
  character ( len = 72 ) temp
  integer value
  integer which
  character ( len = 8 ) xlibr
  character ( len = 8 ) xsubr

  which = 2
  value = 0
  set = .false.

  lkntrl = j4save ( which, value, set )

  which = 4
  value = 0
  set = .false.

  maxmes = j4save ( which, value, set )
!
!  LKNTRL is a local copy of the control flag KONTRL.
!
!  MAXMES is the maximum number of times any particular message
!  should be printed.
!
!  We print a fatal error message and terminate for an error in
!  calling XERMSG.  The error number should be positive,
!  and LEVEL should be between 0 and 2.
!
  if ( nerr .lt. -9999999 .or. &
      99999999 .lt. nerr .or. &
      nerr .eq. 0 .or. &
      level .lt. -1 .or. &
      2 .lt. level ) then

    call xerprn ( ' ***', -1, &
     'Fatal error in...$$ ' // &
     'XERMSG -- Invalid error number or level$$ ' // &
     'Job abort due to fatal error.', 72 )

    call xersve ( ' ', ' ', ' ', 0, 0, 0, kdummy )
    call xerhlt ( ' ***XERMSG -- Invalid input' )
    return

  end if
!
!  Record the message.
!
  which = 1
  value = nerr
  set = .true.

  i = j4save ( which, value, set )

  call xersve ( librar, subrou, messg, 1, nerr, level, kount )
!
!  Handle print-once warning messages.
!
  if ( level .eq. -1 .and. 1 .lt. kount ) then
    return
  end if
!
!  Allow temporary user override of the control flag.
!
  xlibr  = librar
  xsubr  = subrou
  lfirst = messg
  lerr   = nerr
  llevel = level
  call xercnt ( xlibr, xsubr, lfirst, lerr, llevel, lkntrl )

  lkntrl = max ( -2, min ( 2, lkntrl ) )
  mkntrl = abs ( lkntrl )
!
!  Skip printing if the control flag value as reset in xercnt is
!  zero and the error is not fatal.
!
  skip = .false.

  if ( level .lt. 2 .and. lkntrl .eq. 0 ) then
    skip = .true.
  end if

  if ( level .eq. 0 .and. maxmes .lt. kount ) then
    skip = .true.
  end if

  if ( level .eq. 1 .and. maxmes .lt. kount .and. mkntrl .eq. 1 ) then
    skip = .true.
  end if

  if ( level .eq. 2 .and. max ( 1, maxmes ) .lt. kount ) then
    skip = .true.
  end if

  if ( .not. skip ) then
!
!  Announce the names of the library and subroutine by building a
!  message in character variable TEMP (not exceeding 66 characters)
!  and sending it out via XERPRN.  Print only if control flag
!  is not zero.
!
  if ( lkntrl .ne. 0 ) then
    temp(1:21) = 'Message from routine '
    i = min ( len ( subrou ), 16 )
    temp(22:21+i) = subrou(1:i)
    temp(22+i:33+i) = ' in library '
    ltemp = 33 + i
    i = min ( len ( librar ), 16)
    temp(ltemp+1:ltemp+i) = librar (1:i)
    temp(ltemp+i+1:ltemp+i+1) = '.'
    ltemp = ltemp + i + 1
    call xerprn ( ' ***', -1, temp(1:ltemp), 72 )
  end if
!
!  If LKNTRL is positive, print an introductory line before
!  printing the message.  The introductory line tells the choice
!  from each of the following three options.
!
!  1.  Level of the message
!
!  'Informative message'
!  'Potentially recoverable error'
!  'Fatal error'
!
!  2.  Whether control flag will allow program to continue
!
!  'Prog continues'
!  'Prog aborted'
!
!  3.  Whether or not a traceback was requested.  (The traceback
!  may not be implemented at some sites, so this only tells
!  what was requested, not what was delivered.)
!
!  'Traceback requested'
!  'Traceback not requested'
!
!  Notice that the line including four prefix characters will not
!  exceed 74 characters.
!  We skip the next block if the introductory line is not needed.
!
  if ( 0 .lt. lkntrl ) then
!
!  The first part of the message tells about the level.
!
    if ( level .le. 0 ) then
      temp(1:20) = 'Informative message,'
      ltemp = 20
    else if ( level .eq. 1 ) then
      temp(1:30) = 'Potentially recoverable error,'
      ltemp = 30
    else
      temp(1:12) = 'Fatal error,'
      ltemp = 12
    end if
!
!  Then whether the program will continue.
!
    if ( ( mkntrl .eq. 2 .and. 1 .le. level ) .or. &
         ( mkntrl .eq. 1 .and. level .eq. 2 ) ) then
      temp(ltemp+1:ltemp+14) = ' Prog aborted,'
      ltemp = ltemp + 14
    else
      temp(ltemp+1:ltemp+16) = ' Prog continues,'
      ltemp = ltemp + 16
    end if
!
!  Finally tell whether there should be a traceback.
!
    if ( 0 .lt. lkntrl ) then
      temp(ltemp+1:ltemp+20) = ' Traceback requested'
      ltemp = ltemp + 20
    else
      temp(ltemp+1:ltemp+24) = ' Traceback not requested'
      ltemp = ltemp + 24
    end if

    call xerprn ( ' ***', -1, temp(1:ltemp), 72 )

  end if
!
!  Now send out the message.
!
  call xerprn ( ' *  ', -1, messg, 72 )
!
!  IF LKNTRL is positive, write the error number and request a
!  traceback.
!
  if ( 0 .lt. lkntrl ) then

    write ( temp, '(a,i8)' ) '  Error number = ', nerr

    call xerprn ( ' *  ', -1, temp, 72 )
    call fdump ( )

  end if
!
!  IF LKNTRL is not zero, print a blank line and an end of message.
!
  if ( lkntrl .ne. 0 ) then
    call xerprn ( ' *  ', -1, ' ', 72 )
    call xerprn ( ' ***', -1, 'End of message', 72 )
    call xerprn ( '    ',  0, ' ', 72 )
  end if
!
!  If the error is not fatal or the error is recoverable and the
!  control flag is set for recovery, then return.
!
  end if

  if ( level .le. 0 .or. &
    ( level .eq. 1 .and. mkntrl .le. 1 ) ) then
    return
  end if
!
!  The program will be stopped due to an unrecovered error or a
!  fatal error.  Print the reason for the abort and the error
!  summary if the control flag and the maximum error count permit.
!
  if ( 0 .lt. lkntrl .and. kount .lt. max ( 1, maxmes ) ) then

    if ( level .eq. 1 ) then
      call xerprn ( ' ***', -1, 'Job abort due to unrecovered error.', 72 )
    else
      call xerprn ( ' ***', -1, 'Job abort due to fatal error.', 72 )
    end if

    call xersve ( ' ', ' ', ' ', -1, 0, 0, kdummy )
    call xerhlt ( ' ' )

  else

    call xerhlt ( messg )

  end if

  return
end
subroutine xerprn ( prefix, npref, messg, nwrap )

!*****************************************************************************80
!
!! XERPRN prints error messages processed by XERMSG.
!
!  Description:
!
!  Discussion:
!
!    This routine is used by the error handling routine XERMSG.  A related
!    routine, XERPRT, is used by the older error handling routines 
!    XERROR and XERRWV.
!
!    This routine sends one or more lines to each of the (up to five)
!    logical units to which error messages are to be sent.  This routine
!    is called several times by XERMSG, sometimes with a single line to
!    print and sometimes with a (potentially very long) message that may
!    wrap around into multiple lines.
!
!  Modified:
!
!    04 April 2007
!
!  Author:
!
!    Kirby Fong
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) PREFIX, a string to be put at the beginning of
!    each line before the body of the message.  No more than 16 characters
!    of PREFIX will be used.
!
!    Input, integer NPREF, the number of characters to use from PREFIX. 
!    If it is negative, the intrinsic function LEN is used to determine 
!    its length.  If it is zero, PREFIX is not used.  If it exceeds 16 or if
!    LEN(PREFIX) exceeds 16, only the first 16 characters will be
!    used.  If NPREF is positive and the length of PREFIX is less
!    than NPREF, a copy of PREFIX extended with blanks to length
!    NPREF will be used.
!
!    Input, character ( len = * ) MESSG, the error message.  If it is a long 
!    message, it will be broken into pieces for printing on multiple lines.  
!    Each line will start with the appropriate prefix and be followed by a piece
!    of the message.  NWRAP is the number of characters per piece; that is, 
!    after each NWRAP characters, we break and start a new line.  In addition,
!    the characters '$$' embedded in MESSG are a sentinel for a new line.  
!    The counting of characters up to NWRAP starts over for each new line.  
!    The value of NWRAP typically used by XERMSG is 72 since many
!    older error messages in the SLATEC Library are laid out to rely on 
!    wrap-around every 72 characters.
!
!    Input, integer NWRAP, the maximum size piece into which to break MESSG 
!    for printing on multiple lines.  An embedded '$$' ends a line, and the 
!    count restarts at the following character.  If a line break does not occur
!    on a blank (it would split a word) that word is moved to the next line.  
!    Values of NWRAP less than 16 will be treated as 16.  Values of NWRAP 
!    greater than 132 will be treated as 132.  The actual line length will 
!    be NPREF + NWRAP after NPREF has been adjusted to fall between 0 and 16 
!    and NWRAP has been adjusted to fall between 16 and 132.
!
  implicit none

  character ( len = 148 ) cbuff
  integer i
  integer i1mach
  integer idelta
  integer iu(5)
  integer lenmsg
  integer lpiece
  integer lpref
  integer lwrap
  character ( len = * ) messg
  integer n
  character ( len = 2 ), parameter :: newlin = '$$'
  integer nextc
  integer npref
  integer nunit
  integer nwrap
  character ( len = * ) prefix

  call xgetua ( iu, nunit )
!
!  A zero value for a logical unit number means to use the standard
!  error message unit instead.  I1MACH(4) retrieves the standard
!  error message unit.
!
  n = i1mach(4)
  do i = 1, nunit
    if ( iu(i) == 0 ) then
      iu(i) = n
    end if
  end do
!
!  LPREF is the length of the prefix.  The prefix is placed at the
!  beginning of CBUFF, the character buffer, and kept there during
!  the rest of this routine.
!
  if ( npref < 0 ) then
    lpref = len ( prefix )
  else
    lpref = npref
  end if

  lpref = min ( 16, lpref )

  if ( lpref /= 0 ) then
    cbuff(1:lpref) = prefix
  end if
!
!  LWRAP is the maximum number of characters we want to take at one
!  time from MESSG to print on one line.
!
  lwrap = max ( 16, min ( 132, nwrap ) )
!
!  Set LENMSG to the length of MESSG, ignore any trailing blanks.
!
  lenmsg = len ( messg )
  n = lenmsg
  do i = 1, n
    if ( messg(lenmsg:lenmsg) /= ' ' ) then
      exit
    end if
    lenmsg = lenmsg - 1
  end do
!
!  If the message is all blanks, then print one blank line.
!
  if ( lenmsg == 0 ) then
    cbuff(lpref+1:lpref+1) = ' '
    do i = 1, nunit
      write ( iu(i), '(a)' ) cbuff(1:lpref+1)
    end do
    return
  end if
!
!  Set NEXTC to the position in MESSG where the next substring
!  starts.  From this position we scan for the new line sentinel.
!  When NEXTC exceeds LENMSG, there is no more to print.
!  We loop back to label 50 until all pieces have been printed.
!
!  We look for the next occurrence of the new line sentinel.  The
!  INDEX intrinsic function returns zero if there is no occurrence
!  or if the length of the first argument is less than the length
!  of the second argument.
!
!  There are several cases which should be checked for in the
!  following order.  We are attempting to set LPIECE to the number
!  of characters that should be taken from MESSG starting at
!  position NEXTC.
!
!  * LPIECE == 0
!  The new line sentinel does not occur in the remainder of the 
!  character string.  LPIECE should be set to LWRAP or LENMSG+1-NEXTC,
!  whichever is less.
!
!  * LPIECE == 1
!  The new line sentinel starts at MESSG(NEXTC:NEXTC).  LPIECE is effectively 
!  zero, and we print nothing to avoid producing unnecessary blank lines.
!  This takes care of the situation where the library routine has a message of
!  exactly 72 characters followed by a new line sentinel followed by more
!  characters.  NEXTC should be incremented by 2.
!
!  * LWRAP + 1 < LPIECE
!  Reduce LPIECE to LWRAP.
!
!  * Otherwise
!  This last case means 2 <= LPIECE <= LWRAP+1.  Reset LPIECE = LPIECE-1.
!  Note that this properly handles the end case where LPIECE = LWRAP+1.  
!  That is, the sentinel falls exactly at the end of a line.
!
  nextc = 1

  do

    lpiece = index ( messg(nextc:lenmsg), newlin )
!
!  There was no new line sentinel found.
!
    if ( lpiece == 0 ) then

      idelta = 0
      lpiece = min ( lwrap, lenmsg + 1 - nextc )

      if ( lpiece < lenmsg + 1 - nextc ) then
        do i = lpiece+1, 2, -1
          if ( messg(nextc+i-1:nextc+i-1) == ' ' ) then
            lpiece = i - 1
            idelta = 1
            exit
          end if
        end do
      end if

      cbuff(lpref+1:lpref+lpiece) = messg(nextc:nextc+lpiece-1)
      nextc = nextc + lpiece + idelta
!
!  We have a new line sentinel at MESSG(NEXTC:NEXTC+1).
!  Don't print a blank line.
!
    else if ( lpiece == 1 ) then

      nextc = nextc + 2
      cycle
!
!  LPIECE should be set down to LWRAP.
!
    else if ( lwrap + 1 < lpiece ) then

      idelta = 0
      lpiece = lwrap

      do i = lpiece + 1, 2, -1
        if ( messg(nextc+i-1:nextc+i-1) == ' ' ) then
          lpiece = i - 1
          idelta = 1
          exit
        end if
      end do

      cbuff(lpref+1:lpref+lpiece) = messg(nextc:nextc+lpiece-1)
      nextc = nextc + lpiece + idelta
!
!  If we arrive here, it means 2 <= LPIECE <= LWRAP+1.
!  We should decrement LPIECE by one.
!
    else

      lpiece = lpiece - 1
      cbuff(lpref+1:lpref+lpiece) = messg(nextc:nextc+lpiece-1)
      nextc = nextc + lpiece + 2

    end if
!
!  Print.
!
    do i = 1, nunit
      write ( iu(i), '(a)' ) cbuff(1:lpref+lpiece)
    end do

    if ( lenmsg < nextc ) then
      exit
    end if

  end do

  return
end
subroutine xerprt ( messg, nmessg )

!*****************************************************************************80
!
!! XERPRT prints a message on each file indicated by xgetua.
!
!  Discussion:
!
!    This routine is used by the error handling routines XERROR and XERRWV.  
!    A related routine, XERPRN, is used by the more modern error handling 
!    routines XERMSG.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) MESSG, the message to be printed.
!
!    Input, integer NMESSG, the actual number of characters in MESSG.
!
  implicit none

  integer ichar
  integer iunit
  integer kunit
  integer last
  integer lun(5)
  character ( len = * ) messg
  integer messg_len
  integer nmessg
  integer nunit
!
!  Obtain unit numbers and write line to each unit.
!
  call xgetua ( lun, nunit )

  messg_len = len ( messg )

  do kunit = 1, nunit

    iunit = lun(kunit)

    do ichar = 1, messg_len, 72

      last = min ( ichar + 71, messg_len )

      if ( iunit == 0 ) then
        write ( *, '(a)' ) messg(ichar:last)
      else
        write ( iunit, '(a)' ) messg(ichar:last)
      end if

    end do

  end do

  return
end
subroutine xerror ( messg, nerr, level )

!*****************************************************************************80
!
!! XERROR processes a diagnostic error message.
!
!  Discussion:
!
!    This routine processes a diagnostic message, in a manner determined 
!    by the value of LEVEL and the current value of the library error 
!    control flag KONTRL.
!
!    See XSETF for details about KONTRL.
!
!  Example:
!
!    call xerror ( 'SMOOTH -- NUM was zero.', 1, 2 )
!
!    call xerror ( 'INTEG  -- less than full accuracy achieved.', 2, 1 )
!
!    call xerror ( &
!      'ROOTER -- actual zero of f found before interval fully collapsed.', 
!      3, 0 )
!
!    call xerror ( 'EXP    -- underflows being set to zero.', 1, -1 )
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) MESSG, the message to be processed.
!
!    Input, integer NERR, the error number associated with this message.
!    NERR must not be zero.
!
!    Input, integer LEVEL, the error category.
!    * 2, this is an unconditionally fatal error.
!    * 1, this is a recoverable error.  It is normally non-fatal, unless
!         KONTRL has been reset by XSETF.
!    * 0, this is a warning message only.
!    *-1, this is a warning message which is to be printed at most once, 
!         regardless of how many times this call is executed.
!
  implicit none

  integer i1
  integer i2
  integer level
  character ( len = * ) messg
  integer nerr
  integer ni
  integer nmessg
  integer nr
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2

  nmessg = len ( messg )
  ni = 0
  i1 = 0
  i2 = 0
  nr = 0
  r1 = 0.0D+00
  r2 = 0.0D+00

  call xerrwv ( messg, nmessg, nerr, level, ni, i1, i2, nr, r1, r2 )

  return
end
subroutine xerrwv ( messg, nmessg, nerr, level, ni, i1, i2, nr, r1, r2 )

!*****************************************************************************80
!
!! XERRWV processes an error message that includes numeric information.
!
!  Discussion:
!
!    This routine processes a diagnostic message, in a manner determined
!    by the value of LEVEL and the current value of the library error
!    control flag KONTRL.
!
!    See XSETF for details about KONTRL.
!
!    In addition, up to two integer values and two real values may be 
!    printed along with the message.
!
!  Example:
!
!    call xerrwv ( 'SMOOTH -- NUM (=I1) was zero.', 29, 1, 2, 1, num, 
!      0, 0, 0.0, 0.0 )
!
!    call xerrwv ( &
!      'QUADXY -- Requested error (R1) less than minimum(R2).', &
!      54, 77, 1, 0, 0, 0, 2, errreq, errmin )
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) MESSG, the message to be processed.
!
!    Input, integer NMESSG, the number of characters in MESSG.
!
!    Input, integer NERR, the error number associated with this message.
!    NERR must not be zero.
!
!    Input, integer LEVEL, the error category.
!    * 2, this is an unconditionally fatal error.
!    * 1, this is a recoverable error.  It is normally non-fatal, unless
!         KONTRL has been reset by XSETF.
!    * 0, this is a warning message only.
!    *-1, this is a warning message which is to be printed at most once, 
!         regardless of how many times this call is executed.
!
!    Input, integer NI, the number of integer values to be printed. (0 to 2)
!
!    Input, integer I1, I2, the first and second integer values.
!
!    Input, integer NR, the number of real values to be printed. (0 to 2)
!
!    Input, real ( kind = 8 ) R1, R2, the first and second real values.
!
  implicit none

  character ( len = 37 ) form
  integer i
  integer i1
  integer i1mach
  integer i2
  integer ifatal
  integer isizei
  integer isizef
  integer iunit
  integer j4save
  integer junk
  integer kdummy
  integer kount
  integer kunit
  integer lerr
  integer level
  integer lkntrl
  integer llevel
  integer lmessg
  integer lun(5)
  integer maxmes
  character ( len = * ) messg
  integer mkntrl
  integer nerr
  integer ni
  integer nmessg
  integer nr
  integer nunit
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  logical set
  integer value
  integer which
!
!  Get flags
!
  which = 2
  value = 0
  set = .false.

  lkntrl = j4save ( which, value, set )

  which = 4
  value = 0
  set = .false.

  maxmes = j4save ( which, value, set )
!
!  Check for valid input
!
  if ( nmessg <= 0 .or. &
       nerr == 0 .or.   &
       level < -1 .or. &
       2 < level ) then

    if ( 0 < lkntrl ) then
      call xerprt ( 'Fatal error in...', 17 )
    end if

    call xerprt( 'XERROR -- Invalid input', 23 )

    if ( 0 < lkntrl ) then
      call xerprt ( 'Job abort due to fatal error.', 29 )
    end if

    if ( 0 < lkntrl ) then
      call xersav ( ' ', 0, 0, 0, kdummy )
    end if

    call xerabt ( 'XERROR -- invalid input', 23 )
    return

   end if
!
!  Record the message.
!
  which = 1
  value = nerr
  set = .true.

  junk = j4save ( which, value, set )

  if ( junk == 1952 ) then
    write ( *, '(a)' ) 'This is a dummy message!'
  end if

  call xersav ( messg, nmessg, nerr, level, kount )
!
!  Let the user override.
!
  lmessg = nmessg
  lerr = nerr
  llevel = level

  call xerctl ( messg, lmessg, lerr, llevel, lkntrl )
!
!  Reset to original values.
!
  lmessg = nmessg
  lerr = nerr
  llevel = level

  lkntrl = max ( -2, min ( 2, lkntrl ) )
  mkntrl = abs ( lkntrl )
!
!  Decide whether to print message
!
  if ( llevel < 2 .and. lkntrl == 0 ) then
    go to 100
  end if

  if ( ( llevel == -1 .and. min ( 1, maxmes ) < kount ) .or. &
       ( llevel == 0 .and. maxmes < kount ) .or. &
       ( llevel == 1 .and. maxmes < kount .and. mkntrl == 1 ) .or. &
       ( llevel == 2  .and. max ( 1, maxmes ) < kount ) ) then
    go to 100
  end if

  if ( 0 < lkntrl ) then

    call xerprt ( ' ', 1 )

    if ( llevel == -1 ) then
      call xerprt &
      ( 'Warning message...this message will only be printed once.',57)
    else if ( llevel == 0 ) then
      call xerprt ( 'Warning in...', 13 ) 
    else if ( llevel == 1 ) then
      call xerprt ( 'Recoverable error in...', 23 )
    else if ( llevel == 2 ) then
      call xerprt ( 'Fatal error in...', 17 )
    end if

  end if
!
!  Message.
!
  call xerprt ( messg, lmessg )
  call xgetua(lun,nunit)
  isizei = 1 + int ( log10 ( real ( i1mach(9), kind = 8 ) ) )
  isizef = 1 + int ( log10 ( real ( i1mach(10), kind = 8 )**i1mach(14) ) )

  do kunit = 1, nunit

    iunit = lun(kunit)

    do i = 1, min ( ni, 2 )
      write (form,21) i,isizei
   21 format ('(11x,21hin above message, i',i1,'=,i',i2,')   ')
      if ( iunit == 0 ) then
        if ( i == 1 ) write (*,form) i1
        if ( i == 2 ) write (*,form) i2
      else
        if ( i == 1 ) write (iunit,form) i1
        if ( i == 2 ) write (iunit,form) i2
      end if
    end do

    do i = 1, min ( nr, 2 )
      write (form,23) i,isizef+10,isizef
   23 format ('(11x,21hin above message, r',i1,'=,e',i2,'.',i2,')')
      if ( iunit == 0 ) then
        if ( i == 1 ) write (*,form) r1
        if ( i == 2 ) write (*,form) r2
      else
        if ( i == 1 ) write (iunit,form) r1
        if ( i == 2 ) write (iunit,form) r2
      end if
    end do
!
!  Print the error number.
!
    if ( 0 < lkntrl ) then

      if ( iunit == 0 ) then
        write ( *, '(a,i10)' ) '  Error number = ', lerr
      else
        write ( iunit, '(a,i10)' ) '  Error number = ', lerr
      end if

    end if

  end do
!
!  Traceback
!
  if ( 0 < lkntrl ) then
    call fdump ( )
  end if

100 continue

  if ( llevel == 2 .or. ( llevel == 1 .and. mkntrl ==2 ) ) then
    ifatal = 1
  else
    ifatal = 0
  end if
!
!  Quit here if message is not fatal.
!
  if ( ifatal <= 0 ) then
    return
  end if
!
!  Print reason for abort and error summary.
!
  if ( 0 < lkntrl .and. kount <= max ( 1, maxmes ) ) then

    if ( llevel == 1 ) then
      call xerprt ( 'Job abort due to unrecovered error.', 35 )
    end if

    if ( llevel == 2 ) then
      call xerprt ( 'Job abort due to fatal error.', 29 )
    end if

    call xersav ( ' ', -1, 0, 0, kdummy )

  end if
!
!  Abort
!
  if ( llevel == 2 .and. max ( 1, maxmes ) < kount ) then
    lmessg = 0
  end if

  call xerabt ( messg, lmessg )

  return
end
subroutine xersav ( messg, nmessg, nerr, level, count )

!*****************************************************************************80
!
!! XERSAV records that an error occurred.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character ( len = * ) MESSG, as in XERROR.
!
!    Input, integer NMESSG, as in XERROR, except that, when NMESSG = 0,
!    the tables will be dumped and cleared; and when NMESSG < 0,
!    the tables will be dumped, but not cleared.
!
!    Input, integer NERR, the error number.  NERR should not be 0.
!
!    Input, integer LEVEL, the error severity level.
!    * 2, this is an unconditionally fatal error.
!    * 1, this is a recoverable error.  It is normally non-fatal, unless
!         KONTRL has been reset by XSETF.
!    * 0, this is a warning message only.
!    *-1, this is a warning message which is to be printed at most once, 
!         regardless of how many times this call is executed.
!
!    Output, integer COUNT, the number of times this message has
!    been seen, or zero if the table has overflowed and does not contain 
!    this message specifically.
!    When NMESSG = 0, COUNT will not be altered.
!
  implicit none

  integer count
  integer i
  integer i1mach
  integer ii
  integer iunit
  integer, save, dimension ( 10 ) :: kount = (/ &
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /)
  integer, save :: kountx = 0
  integer kunit
  integer level
  integer, save, dimension ( 10 ) :: levtab = (/ &
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /)
  integer lun(5)
  character ( len = 20 ) mes
  character ( len = * ) messg
  character ( len = 20 ), save, dimension ( 10 ) :: mestab
  integer nerr
  integer, save, dimension ( 10 ) :: nertab = (/ &
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /)
  integer nmessg
  integer nunit
!
!  Dump the table
!
  if ( nmessg <= 0 ) then

     if ( kount(1) == 0 ) then
       return
     end if
!
!  Print to each unit
!
     call xgetua ( lun, nunit )

     do kunit = 1, nunit

       iunit = lun(kunit)
       if ( iunit == 0 ) then
         iunit = i1mach(4)
       end if
!
!  Print table header
!
       write ( iunit, '(a)' ) ' '
       write ( iunit, '(a)' ) &
       '          Error message summary'
       write ( iunit, '(a)' ) &
       'Message start             NERR     Level     Count'
!
!  Print body of table.
!
        do i = 1, 10

          if ( kount(i) == 0 ) then
            exit
          end if

          write ( iunit, '(a20,3i10)' ) &
            mestab(i), nertab(i), levtab(i), kount(i)

        end do
!
!  Print number of other errors.
!
        if ( kountx /= 0 ) then
          write ( iunit, '(a)' ) ' '
          write ( iunit, '(a,i10)' ) &
            'Other errors not individually tabulated = ', kountx
        end if

        write ( iunit, '(a)' ) ' '

     end do

     if ( nmessg < 0 ) then
       return
     end if
!
!  Clear the error tables.
!
    kount(1:10) = 0
    kountx = 0
!
!  Process a message.
!
!  Search for this message, or else an empty slot for this message,
!  or else determine that the error table is full.
!
  else

    mes(1:20) = messg(1:20)

    do i = 1, 10

      ii = i
!
!  An empty slot was found for the new message.
!
      if ( kount(i) == 0 ) then
        mestab(ii) = mes
        nertab(ii) = nerr
        levtab(ii) = level
        kount(ii)  = 1
        count = 1
        return
      end if
!
!  Message found in table.
!
      if ( mes == mestab(i) .and.  &
           nerr == nertab(i) .and. &
           level == levtab(i) ) then
        kount(ii) = kount(ii) + 1
        count = kount(ii)
        return
      end if

    end do
!
!  The table is full.
!
    kountx = kountx + 1
    count = 1

  end if

  return
end
subroutine xersve ( librar, subrou, messg, kflag, nerr, level, icount )

!*****************************************************************************80
!
!! XERSVE records that an error has occurred.
!
!  Discussion:
!
!    This routine is used by the error handling routines associated
!    with XERMSG.  It is a revised version of the routine XERSAV, which
!    was used with the older pair of error handling routines XERROR
!    and XERRWV.
!
!  Modified:
!
!    06 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, character (len = * ) LIBRAR, the name of the library or software
!    package from which the error message comes.
!
!    Input, character (len = * ) SUBROU, the name of the subroutine or function
!    from which the error message comes.
!
!    Input, character (len = * ) MESSG, the error message.
!
!    Input, integer KFLAG, indicates the action to be performed.
!    0 < KFLAG, the message in MESSG is saved.
!    KFLAG=0 the tables will be dumped and cleared.
!    KFLAG < 0, the tables will be dumped and not cleared.
!
!    Input, integer NERR, the error number.
!
!    Input, integer LEVEL, the error severity.
!
!    Output, integer ICOUNT, the number of times this message has been seen,
!    or zero if the table has overflowed and does not contain this message 
!    specifically.  When KFLAG=0, ICOUNT will not be altered from its
!    input value.
!
  implicit none

  integer, parameter :: lentab = 10

  integer i
  integer i1mach
  integer icount
  integer iunit
  integer kflag
  integer, save, dimension ( lentab ) :: kount
  integer, save :: kountx = 0
  integer kunit
  integer level
  integer, save, dimension ( lentab ) :: levtab
  character ( len = 8 ) lib
  character (len = * ) librar
  character ( len = 8 ), save, dimension ( lentab ) :: libtab
  integer lun(5)
  character ( len = 20 ) mes
  character (len = * ) messg
  character ( len = 20 ), save, dimension ( lentab ) :: mestab
  integer nerr
  integer, save, dimension ( lentab ) :: nertab
  integer, save :: nmsg = 0
  integer nunit
  character ( len = 8 ) sub
  character (len = * ) subrou
  character ( len = 8 ), save, dimension ( lentab ) :: subtab

  if ( kflag <= 0 ) then
!
!  Dump the table.
!
    if ( nmsg == 0 ) then
      return
    end if
!
!  Print to each unit.
!
    call xgetua ( lun, nunit )

    do kunit = 1, nunit

      iunit = lun(kunit)
      if ( iunit == 0 ) then
        iunit = i1mach(4)
      end if
!
!  Print the table header.
!
      write ( iunit, '(a)' ) ' '
      write ( iunit, '(a)' ) '          Error message summary'
      write ( iunit, '(a,a)' ) &
        'Library    Subroutine Message start             NERR', &
        '     Level     Count'

!
!  Print body of table.
!
      do i = 1, nmsg
        write ( iunit, '(a,3x,a,3x,a,3i10)' ) &
          libtab(i), subtab(i), mestab(i), nertab(i), levtab(i), kount(i)
      end do
!
!  Print the number of other errors.
!
      if ( kountx /= 0 ) then
        write ( iunit, '(a)' ) ' '
        write ( iunit, '(a,i10)' ) &
          'Other errors not individually tabulated = ', kountx
      end if

      write ( iunit, '(1x)' )

    end do
!
!  Clear the error tables.
!
    if ( kflag == 0 ) then
      nmsg = 0
      kountx = 0
    end if

  else
!
!  Process a message.
!
!  Search for this message, or else an empty slot for this message,
!  or else determine that the error table is full.
!
    lib = librar
    sub = subrou
    mes = messg

    do i = 1, nmsg

      if ( &
        lib == libtab(i) .and.  &
        sub == subtab(i) .and.  &
        mes == mestab(i) .and.  &
        nerr == nertab(i) .and. &
        level == levtab(i) ) then
        kount(i) = kount(i) + 1
        icount = kount(i)
        return
      end if

    end do
!
!  Empty slot found for new message.
!
    if ( nmsg < lentab ) then

      nmsg = nmsg + 1
      libtab(i) = lib
      subtab(i) = sub
      mestab(i) = mes
      nertab(i) = nerr
      levtab(i) = level
      kount(i)  = 1
      icount    = 1
!
!  Table is full.
!
    else

      kountx = kountx + 1
      icount = 0

    end if

  end if

  return
end
subroutine xgetf ( kontrl )

!*****************************************************************************80
!
!! XGETF returns current value of error control flag.
!
!  Discussion:
!
!    This routine returns the current value of KONTRL, the error 
!    control flag.
!
!    The amount of output printed for a given error is determined
!    by LEVEL, the level of severity, and KONTRL, which controls
!    how much output the user wants to see.
!
!    The following table shows how each message is treated,
!    depending on the values of KONTRL and LEVEL.
!
!    If KONTRL is zero or negative, no information other than the
!    message itself (including numeric values, if any) will be
!    printed.  If KONTRL is positive, introductory messages,
!    trace-backs, and so on, will be printed in addition to the message.
!
!            KONTRL   0            -1/+1          -2/+2
!        LEVEL
!          2        fatal          fatal          fatal
!          1     not printed      printed         fatal
!          0     not printed      printed        printed
!         -1     not printed      printed once   printed once
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Output, integer KONTRL, the current value of the error control flag.
!
  implicit none

  integer j4save
  integer kontrl
  logical set
  integer value
  integer which

  which = 2
  value = 0
  set = .false.

  kontrl = j4save ( which, value, set )

  return
end
subroutine xgetua ( iunit, nunit )

!*****************************************************************************80
!
!! XGETUA returns the unit numbers to which error messages are being sent.
!
!  Discussion:
!
!    These unit numbers may have been set by a call to XSETUN,
!    or a call to XSETUA, or may be default values.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Output, integer IUNIT(5), an array into which the routine will
!    store the values of the NUNIT units to which the error messages
!    are being sent.  The value of NUNIT is never more than 5, so
!    using an array of dimension 5 will be sufficient.
!
!    Output, integer NUNIT, the number of units to which the
!    error messages are being sent.  NUNIT will be in the
!    range from 1 to 5.
!
  implicit none

  integer i
  integer iunit(5)
  integer j4save
  integer nunit
  logical set
  integer value
  integer which

  which = 5
  value = 0
  set = .false.

  nunit = j4save ( which, value, set)

  if ( nunit < 1 ) then
    return
  end if

  which = 3
  value = 0
  set = .false.

  iunit(1) = j4save ( which, value, set )

  do i = 2, nunit

    which = i + 4
    value = 0
    set = .false.

    iunit(i) = j4save ( which, value, set )

  end do

  return
end
subroutine xgetun ( iunit )

!*****************************************************************************80
!
!! XGETUN returns the (first) output file to which messages are being sent.
!
!  Discussion:
!
!    This routine returns the unit number associated with the first or
!    main file to which error messages are being sent.  
!
!    To find out if more than one file is being used for error output, 
!    one must use the XGETUA routine.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Output, integer IUNIT, the logical unit number of the first unit
!    to which error messages are being sent.
!
  implicit none

  integer iunit
  integer j4save
  logical set
  integer value
  integer which

  which = 3
  value = 0
  set = .false.

  iunit = j4save ( which, value, set )

  return
end
subroutine xsetf ( kontrl )

!*****************************************************************************80
!
!! XSETF sets the error control flag.
!
!  Discussion:
!
!    This routine sets the error control flag value to KONTRL.
!
!    The following table shows how each message is treated,
!    depending on the values of KONTRL and LEVEL.  See XERROR
!    for description of LEVEL.
!
!    If KONTRL is zero or negative, no information other than the
!    message itself (including numeric values, if any) will be
!    printed.  If KONTRL is positive, introductory messages,
!    trace-backs, and so on, will be printed in addition to the message.
!
!            KONTRL   0            -1/+1          -2/+2
!        LEVEL
!          2        fatal          fatal          fatal
!          1     not printed      printed         fatal
!          0     not printed      printed        printed
!         -1     not printed      printed once   printed once
!
!  Modified:
!
!    08 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, integer KONTRL, the desired value of the error control flag.
!
  implicit none

  integer j4save
  integer junk
  integer kontrl
  integer level
  integer nerr
  logical set
  integer value
  integer which
  character ( len = 8 ) xern1

  if ( kontrl < -2 .or. 2 < kontrl ) then

    write ( xern1, '(i8)' ) kontrl
    nerr = 1
    level = 2

    call xermsg ( 'XERROR', 'XSETF', &
      'Invalid value of KONTRL = ' // xern1, nerr, level )

    return

  end if

  which = 2
  value = kontrl
  set = .true.

  junk = j4save ( which, value, set )

  if ( junk == 1952 ) then
    write ( *, '(a)' ) 'This is a dummy message!'
  end if

  return
end
subroutine xsetua ( iunita, nunit )

!*****************************************************************************80
!
!! XSETUA sets up to 5 unit numbers to which messages are to be sent.
!
!  Discussion:
!
!    This routine may be called to declare a list of up to five
!    logical units, each of which is to receive a copy of
!    each error message processed by this package.
!
!    The existence of multiple error output units makes it possible for
!    the user to ensure simultaneous printing of each error message to, 
!    say, a main output file, an interactive terminal, and other files 
!    such as graphics communication files.
!
!  Modified:
!
!    08 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, integer IUNIT(NUNIT), unit numbers to which the error messages
!    should be printed.  Normally these numbers should all be different
!    but duplicates are not prohibited.
!
!    Input, integer NUNIT, the number of unit numbers provided in IUNIT.
!    1 <= N <= 5.
!
  implicit none

  integer nunit

  integer i
  integer iunita(nunit)
  integer j4save
  integer junk
  integer level
  integer nerr
  logical set
  integer value
  integer which
  character ( len = 8 ) xern1

  if ( nunit < 1 .or. 5 < nunit ) then

    write ( xern1, '(i8)' ) nunit
    nerr = 1
    level = 2

    call xermsg ( 'XERROR', 'XSETUA', &
      'Invalid number of units, NUNIT = ' // xern1, nerr, level )

    return

  end if
!
!  Set the main error output unit.
!
  which = 3
  value = iunita(1)
  set = .true.

  junk = j4save ( which, value, set )

  if ( junk == 1952 ) then
    write ( *, '(a)' ) 'This is a dummy message!'
  end if
!
!  If 1 < NUNIT, set auxilliary output units.
!
  do i = 2, nunit

    which = i + 4
    value = iunita(i)
    set = .true.

    junk = j4save ( which, value, set )

  end do

  which = 5
  value = nunit
  set = .true.

  junk = j4save ( which, value, set )

  return
end
subroutine xsetun ( iunit )

!*****************************************************************************80
!
!! XSETUN sets the output file to which error messages are to be sent.
!
!  Discussion:
!
!    This routine sets the unit number associated with the main error
!    output file.  If auxilliary error output units were defined, 
!    this routine suppresses them, as well.
!
!    Note that this error package initializes this unit number to the standard
!    output file, a reasonable choice.
!
!    Common choices for the unit number to be associated with the main
!    error output file might be 1, 6 or 9.  FORTRAN generally requires 
!    that such unit numbers be between 1 and 99.  Depending on the 
!    compiler, units -1 or 0 might also be legal choices.  It may 
!    be the case that some unit numbers cannot be chosen, because 
!    they are reserved by the compiler for other purposes.  In 
!    particular, some compilers reserve unit 5 for input.
!
!    Copies of the error output may also be sent to up to four auxilliary 
!    units, which can be defined by calling XSETUA.
!
!  Modified:
!
!    05 April 2007
!
!  Author:
!
!    Ron Jones
!
!  Reference:
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Technical Report SAND82-0800,
!    Sandia National Laboratories, 1982.
!
!    Ron Jones, David Kahaner,
!    XERROR, The SLATEC Error Handling Package,
!    Software: Practice and Experience,
!    Volume 13, Number 3, 1983, pages 251-257.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, integer IUNIT, the logical unit number to which error 
!    messages are to be sent.
!
  implicit none

  integer iunit
  integer j4save
  integer junk
  integer nunit
  logical set
  integer value
  integer which
!
!  Set the main error output unit.
!
  which = 3
  value = iunit
  set = .true.

  junk = j4save ( which, value, set )

  if ( junk == 1952 ) then
    write ( *, '(a)' ) 'This is a dummy message!'
  end if
!
!  Suppress all the other error output units.
!
  nunit = 1

  which = 5
  value = nunit
  set = .true.

  junk = j4save ( which, value, set )

  return
end