      function polardens(r,ctheta,l)
      parameter(pi=3.1415926535)
c returns density at r,theta, multiplied by the lth harmonic
c (must integrate this over theta to get the harmonic coeff)
      common/legendre/ plcon(0:40)
      z=r*ctheta
      s=r*sqrt(1.0 - ctheta*ctheta)
!      print*,r,s,dens(s,z),plgndr1(l,ctheta),plcon(l)
      polardens=dens(s,z)*plcon(l)*plgndr1(l,ctheta)
      return
      end


      module MOD_TRADFUN
      contains
C**********  MODULNAME: TRADFUN   ******* 24/03/87  22.14.04.******    12 KARTEN
      FUNCTION TRADFUN (XLAMBDA,XJ)
C***  RADIATION TEMPERAURE IN KELVIN, FROM XJ = J-NUE (CGS UNITS)
C***  AND XLAMBDA IN ANGSTROEM
C***  CONSTANTS :  C1 = H * C / K   (DIMENSION ANGSTROEM * KELVIN )
C***               C2 = 2 * H * C

      implicit real*8(a-h,o-z)

      DATA C1,C2 / 1.4388d8, 3.9724d+8 /

      TRADFUN=.0d0
      IF (XJ.LE..0) RETURN
      TRADFUN=C1/XLAMBDA/LOG(C2/XLAMBDA/XLAMBDA/XLAMBDA/XJ +1.d0)

      RETURN
      END function
      end module


!*******************************************************************************
!> author: Jacob Williams
!  date: October 31, 2016
!
!  Test1 for the numerical differentiation module.

    program test1

    use iso_fortran_env, only: wp => real64, output_unit, error_unit
    use numerical_differentiation_module

    implicit none

    integer,parameter :: n = 10
    integer,parameter :: m = 6
    real(wp),dimension(n),parameter :: x     = 1.0_wp
    real(wp),dimension(n),parameter :: xlow  = -10.0_wp
    real(wp),dimension(n),parameter :: xhigh = 10.0_wp
    real(wp),dimension(n),parameter :: dpert = 1.0e-5_wp
    integer,parameter :: perturb_mode = 1
    integer,parameter :: cache_size = 0 !! `0` indicates not to use cache
    !integer,parameter :: cache_size = 1000 ! use cache
   ! integer,parameter :: sparsity_mode = 2
    integer,parameter :: sparsity_mode = 4

    type(numdiff_type)                :: my_prob
    integer                           :: i          !! counter
    integer                           :: j          !! counter
    real(wp),dimension(:),allocatable :: jac
    character(len=:),allocatable      :: formula
    type(finite_diff_method)          :: fd
    logical                           :: status_ok
    type(meth_array)                  :: meths
    integer                           :: func_evals  !! function evaluation counter
    integer,dimension(:),allocatable  :: methods     !! array of method IDs
    character(len=:),allocatable      :: error_msg   !! error message string

    methods = [(i, i = 1, 44)]
    methods = [methods, 500,600,700,800]  ! these only have central diffs

    do j=1,size(methods)  ! try different finite diff methods

        i = methods(j)

        call get_finite_diff_formula(i,formula)
        if (formula=='') then
            write(output_unit,*) 'id ', i , 'not available'
            cycle
        end if
        func_evals = 0
        call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,&
                                problem_func=my_func,&
                                sparsity_mode=sparsity_mode,&
                                jacobian_method=i,&
                                partition_sparsity_pattern=.false.,&
                                cache_size=cache_size)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if

        call my_prob%compute_jacobian(x,jac)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if

        if (i==1) then
            write(output_unit,'(A)') ''
            call my_prob%print_sparsity_pattern(output_unit)
            write(output_unit,'(A)') ''
            call my_prob%print_sparsity_matrix(output_unit)
            write(output_unit,'(A)') ''

            write(output_unit,'(A)') ''
            write(output_unit,'(A)') '--------------------------------------'
            write(output_unit,'(A,I4)') ' specify method [no partitioning] : ',i
            write(output_unit,'(A)') '--------------------------------------'
            write(output_unit,'(A)') ''
        end if

        write(output_unit,'(A)') formula
        write(output_unit,'(A)') ''
        write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac
        write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals
        write(output_unit,'(A)') ''

    end do

    do j=1,size(methods)  ! try different finite diff methods

        i = methods(j)

        call get_finite_diff_formula(i,formula)
        if (formula=='') then
            write(output_unit,*) 'id ', i , 'not available'
            cycle
        end if

        func_evals = 0
        call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,&
                                problem_func=my_func,&
                                sparsity_mode=sparsity_mode,&
                                jacobian_method=i,&
                                partition_sparsity_pattern=.true.,&
                                cache_size=cache_size)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if

        call my_prob%compute_jacobian(x,jac)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if

        if (i==1) then
            write(output_unit,'(A)') ''
            call my_prob%print_sparsity_pattern(output_unit)
            write(output_unit,'(A)') ''
            call my_prob%print_sparsity_matrix(output_unit)
            write(output_unit,'(A)') ''

            write(output_unit,'(A)') ''
            write(output_unit,'(A)') '--------------------------------------'
            write(output_unit,'(A,I4)') ' specify method [with partitioning] : ',i
            write(output_unit,'(A)') '--------------------------------------'
            write(output_unit,'(A)') ''
        end if

        write(output_unit,'(A)') formula
        write(output_unit,'(A)') ''
        write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac
        write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals
        write(output_unit,'(A)') ''

    end do

    meths = get_all_methods_in_class(3)

    write(output_unit,'(A)') ''
    write(output_unit,'(A)') '-------------------'
    write(output_unit,'(A)') 'select_finite_diff_method'
    write(output_unit,'(A)') '-------------------'
    write(output_unit,'(A)') ''
    call my_prob%select_finite_diff_method(0.0_wp,0.0_wp,1.0_wp,0.001_wp,meths,fd,status_ok)
    call fd%get_formula(formula)
    write(output_unit,'(A)') formula
    write(output_unit,'(A)') ''

    call my_prob%select_finite_diff_method(0.9999_wp,0.0_wp,1.0_wp,0.001_wp,meths,fd,status_ok)
    call fd%get_formula(formula)
    write(output_unit,'(A)') formula
    write(output_unit,'(A)') ''

    do i=2,9

        write(output_unit,'(A)') ''
        write(output_unit,'(A)') '-------------------'
        write(output_unit,'(A,I2)') ' specify class [no partitioning] : ', i
        write(output_unit,'(A)') '-------------------'
        write(output_unit,'(A)') ''

        func_evals = 0
        call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,&
                                problem_func=my_func,&
                                sparsity_mode=sparsity_mode,&
                                class=i,&
                                cache_size=cache_size)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if

        call my_prob%compute_jacobian(x,jac)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if
        write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac
        write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals
        write(output_unit,'(A)') ''

    end do

    do i=2,9

        write(output_unit,'(A)') ''
        write(output_unit,'(A)') '-------------------'
        write(output_unit,'(A,I2)') ' specify class [with partitioning] : ',i
        write(output_unit,'(A)') '-------------------'
        write(output_unit,'(A)') ''

        func_evals = 0
        call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,&
                                problem_func=my_func,&
                                sparsity_mode=sparsity_mode,&
                                class=i,partition_sparsity_pattern=.true.,&
                                cache_size=cache_size)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if

        call my_prob%compute_jacobian(x,jac)
        if (my_prob%failed()) then
            call my_prob%get_error_status(error_msg=error_msg)
            write(error_unit,'(A)') error_msg
            stop
        end if
        write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac
        write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals
        write(output_unit,'(A)') ''

    end do

    write(output_unit,'(A)') ''
    write(output_unit,'(A)') '-------------------'
    write(output_unit,'(A)') ' diff algorithm'
    write(output_unit,'(A)') '-------------------'
    write(output_unit,'(A)') ''

    func_evals = 0
    call my_prob%diff_initialize(n,m,xlow,xhigh,my_func,sparsity_mode=1,&  ! use a dense method for this one
                                    cache_size=cache_size)
    if (my_prob%failed()) then
        call my_prob%get_error_status(error_msg=error_msg)
        write(error_unit,'(A)') error_msg
        stop
    end if

    call my_prob%compute_jacobian(x,jac)
    if (my_prob%failed()) then
        call my_prob%get_error_status(error_msg=error_msg)
        write(error_unit,'(A)') error_msg
        stop
    end if
    write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac
    write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals
    write(output_unit,'(A)') ''

contains

    subroutine my_func(me,x,f,funcs_to_compute)

    !! Problem function

    implicit none

    class(numdiff_type),intent(inout) :: me
    real(wp),dimension(:),intent(in)  :: x
    real(wp),dimension(:),intent(out) :: f
    integer,dimension(:),intent(in)   :: funcs_to_compute

    if (any(funcs_to_compute==1)) f(1) = x(1)*x(2) - x(3)**3
    if (any(funcs_to_compute==2)) f(2) = x(3) - 1.0_wp
    if (any(funcs_to_compute==3)) f(3) = x(4)*x(5)
    if (any(funcs_to_compute==4)) f(4) = 2.0_wp*x(6) + sin(x(7))
    if (any(funcs_to_compute==5)) f(5) = cos(x(8)) + sqrt(abs(x(9)))
    if (any(funcs_to_compute==6)) f(6) = 1.0_wp / (1.0_wp + exp(x(10)))

    func_evals = func_evals + 1

    end subroutine my_func

!*******************************************************************************
    end program test1
!*******************************************************************************


c ----------------------------------------------------------------------
      subroutine stat2 (x,npts,xmsg,xmean,xvar,xsd,nptused,ier)

c this routine will calculate estimates of the first two  moments
c .   of the vector x containing missing data.

c input arguments:
c .   x        - input vector
c .   npts     - length of x
c .   xmsg     - missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.

c output arguments:
c .   xmean    - mean of x (first moment)
c .   xvar     - sample variance
c .   xsd      - sqrt( xvar )
c .   nptused  - no. of points used to calculate the estimates
c .   ier      - if (ier.ne.0) an error has occurred

c note :
c .   uncalculated quantities are set to xmsg (nptused set to zero)

      integer npts  , nptused, ier
      real x(1:npts), xmsg, xmean, xvar, xsd
      double precision x1, x2, x3, temp

      xmean   = xmsg
      xvar    = xmsg
      xsd     = xmsg
      nptused = 0

      if (npts.lt.1) then
         ier = 1
         return
      endif

      ier = 0
      x1  = 0.d0
      x2  = 0.d0
      xn  = 0.
      do n=1,npts
         if (x(n).ne.xmsg) then
             xn = xn + 1.0
             x1 = x1 + dble(x(n))
             x2 = x2 + dprod( x(n),x(n) )
         endif
      enddo

      nptused = xn

      if ((xn-1.).gt.0.) then
         x3    = x1*x1/dble(xn)
         temp  = (x2-x3)/dble(xn-1.)
         xvar  = sngl(dmax1( temp  , 0.d0 )) ! prevent possible roundoff
         xsd   = sqrt( xvar )
         xmean = sngl(x1/dble(xn))
      elseif ((xn-1.).eq.0.) then
         xmean = sngl(x1)
         xvar  = 0.0
         xsd   = 0.0
      else
         ier = 2    ! error code for all msg values
      endif

      return
      end
c ----------------------------------------------------------------------
      subroutine stat2t (x,npts,xmsg,xmeant,xvart,xsdt,nptused
     1                  ,work,ptrim,ier)

c this routine will calculate trimmed estimates of the first
c .   two moments of the vector x containing missing data.

c input arguments:
c .   x        - input vector
c .   npts     - length of x  (npts.ge.5 if pctrim.gt.0.)
c .   xmsg     - missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.
c .   work     - work vector of length npts
c .              upon return work contains x in ascending order
c .   ptrim    - portion of the series to be trimmed (0.<= pctrim <1.)
c .              if (pctrim.eq.0.) then
c .                  calculate whole series mean and st dev
c .              else
c .                  a minimum of two pts will be trimmed
c .                  a maximum of npts-2 will be trimmed
c .              endif
c .
c .              note: if u want to be very conservative and only
c .                    trim the min and max values then set
c .                    ptrim to some very small value (e.g. 1.e-36)
c .
c .              ex: npts=45, ptrim=0.50 then
c .                  0.5*45=22 pts will be trimmed (11 on each end)

c output arguments:
c .   xmeant   - mean of trimmed series x
c .   xvart    - sample trimmed variance
c .   xsdt     - sqrt( xvart ): st deviation of trimmed series
c .   nptused  - no. of points used to calculate the trimmed estimates
c .   ier      - if (ier.ne.0) an error has occurred

c note : uncalculated quantities are set to xmsg (nptused set to zero)

      real x(1:npts)  , work(1:npts)

      ier     = 0
      xmeant  = xmsg
      xvart   = xmsg
      xsdt    = xmsg
      nptused = 0

      if (npts.lt.1) then
         ier = 1
         return
      endif

      if (ptrim.eq.0.) then
          call stat2 (x,npts,xmsg,xmeant,xvart,xsdt,nptused,ier)
          return
      elseif (ptrim.eq.1.) then
          ier = 2     ! cannot trim whole series
          return
      endif

c sort x into numerically ascending order
c .   first transfer the input array to the work array
c .   excluding missing pts

      mpts = 0
      do n=1,npts
         if (x(n).ne.xmsg) then
             mpts       = mpts+1
             work(mpts) = x(n)
         endif
      enddo

      if (mpts.lt.1) then
          ier = 3                   ! series contains all msg values
          return
      elseif (mpts.lt.npts) then
          do m=mpts+1,npts          ! fill the rest of work with msg code
             work(m) = xmsg
          enddo
      endif

      call sortu(work,mpts)         ! sort series in ascending order

      mtrim = max0( int( float(mpts)*0.5*ptrim ), 1)   ! no. of values trimmed
                                                       ! from one side

      if ((mpts-2*mtrim).gt.0) then
          call stat2 (work(mtrim+1),mpts-2*mtrim,xmsg,xmeant
     1               ,xvart,xsdt,nptused,ier)
      else
          ier = 4                   ! not enough trimmed values
      endif

      return
      end
c ----------------------------------------------------------------------
      subroutine stat4 (x,npts,xmsg,xmean,xvar,xsd,xskew,xkurt
     1                 ,nptused,ier)

c this routine will calculate estimates of the first four moments
c .   of the vector x containing missing data.

c input arguments:
c .   x        - input vector
c .   npts     - length of x
c .   xmsg     - missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.

c output arguments:
c .   xmean    - mean of x (first moment)
c .   xvar     - sample variance of x (second moment)
c .   xsd      - sqrt( xvar )
c .   xskew    - coef. of skewness (third moment)
c .              departure from symmetry. if skew>0 [skew<0] the
c .              distribution trails off to the right [left] .
c .   xkurt    - coef. of kurtosis (fourth moment)
c .              the normal distribution has a kurtosis of 3 . this
c .              value is subtracted from the calculated kurtosis.
c .              thus neg values are possible and the returned value
c .              is kurtosis relative to the normal distribution.
c .              if (kurt-3) > 0 [<0] it is usually more sharply peaked
c .              [flatter] than the normal distribution. (leptokurtic and
c .              platykurtic , respectively.) e.g. , a rectangular function has
c .              a kurtosis of 1.8 or 1.8-3 = -1.2 relative to the normal
c .              distribution.
c .   nptused  - no. of points used to calculate the estimates
c .   ier      - if (ier.ne.0) an error has occurred

c note :
c .   uncalculated quantities are set to xmsg (nptused set to zero)

      real x(1:npts)
      double precision x1, x2, x3, x4, dxvar

      xmean = xmsg
      xvar  = xmsg
      xsd   = xmsg
      xskew = xmsg
      xkurt = xmsg
      nptused = 0

      if (npts.lt.1) then
         ier = 1
         return
      endif

      ier = 0
      x1  = 0.d0
      x2  = 0.d0
      xn  = 0.
      do n=1,npts
         if (x(n).ne.xmsg) then
             xn = xn + 1.0
             x1 = x1 + dble(x(n))
             x2 = x2 + dprod( x(n),x(n) )
         endif
      enddo

      nptused = xn

      if ((xn-1.).gt.0.) then
         x3    = x1*x1/dble(xn)
         dxvar = dmax1( (x2-x3)/dble(xn-1.) , 0.d0 ) !prevent possible roundoff
         xvar  = sngl( dxvar )
         xsd   = sqrt( xvar )
         xmean = sngl(x1/dble(xn))

         if (dxvar.gt.0.d0) then
             x1 = 0.d0
             x2 = 0.d0
             x3 = 0.d0
             x4 = 0.d0
             do n=1,npts
                if (x(n).ne.xmsg) then
                    x4 = dble(x(n)-xmean)
                    x1 = x4**3
                    x2 = x2 + x1
                    x3 = x3 + x1*x4
                endif
             enddo
             xskew = sngl( (x2/dsqrt(dxvar)**3)/dble(xn))
             xkurt = sngl( (x3/(dxvar*dxvar))/dble(xn)) - 3.
         endif
      elseif ((xn-1.).eq.0.) then
         xmean = sngl(x1)
         xvar  = 0.0
         xsd   = 0.0
      else
         ier = 2    ! error code for all msg values
         return
      endif

      return
      end
c ----------------------------------------------------------------------
      subroutine medmrng (x,work,npts,xmsg,xmedian,xmrange
     1                   ,xrange,nptused,ier)

c this routine will find the median, range and mid-range
c .   of the input  vector x containing missing data.

c arguments :
c .   x        - input vector (series)
c .   work     - work vector of length npts. upon output
c .              work(1) thru work(nptused) are in numerically ascending
c .              order. work(nptused+1) thru work(npts) will be filled
c .              the missing value code.
c .   npts     - length of x
c .   xmsg     - missing code: if no msg values set to some number
c .                            which will not be encountered.
c .   xmedian  - median value of vector x
c .   xmrange  - midrange
c .   xrange   - range of x
c .   nptused  - no. of points used in computing various quantities
c .   ier      - if (ier.ne.0) an error has occurred

c note :
c .   uncalculated quantities are set to xmsg (nptused set to zero)

      real x(1:npts) , work(1:npts)

      xmedian = xmsg
      xmrange = xmsg
      xrange  = xmsg
      nptused = 0

      if (npts.lt.1) then
         ier = 1
         return
      endif
      ier     = 0

c sort x into numerically ascending order
c .   first transfer the input array to the work array
c .   excluding missing pts

      mpts = 0
      do n=1,npts
         if (x(n).ne.xmsg) then
             mpts       = mpts+1
             work(mpts) = x(n)
         endif
      enddo

      if (mpts.lt.1) then
          ier = 2                     ! series contains all msg values
          return
      endif

      call sortu(work,mpts)

      if (mpts.lt.npts) then
          do n=mpts+1,npts            ! fill the rest of work with msg code
             work(n) = xmsg
          enddo
      endif

      xmrange = 0.5*( work(mpts)+work(1) )
      xrange  =       work(mpts)-work(1)

      if (amod(float(mpts),2.).eq.0.) then
          xmedian = 0.5*(work(mpts/2)+work(mpts/2+1) )
      else
          xmedian  = work((mpts+1)/2)
      endif

      nptused = mpts          ! for nomenclature compatibility

      return
      end
c ----------------------------------------------------------------------
      subroutine esauto (x,npts,xmsg,xmean,xvar,mxlag,acv,acr,ier)

c this routine will estimate the autocovariances and autocorrelations
c .   for the input vector x with missing data. the normalizing factor
c .   in the denominator (xvar) is kept constant.

c arguments :
c .   x        - input vector
c .   npts     - length of vector x
c .   xmsg     - missing code: if no msg values set to some number
c .                            which will not be encountered.
c .   xmean    - mean of the input vector x
c .   xvar     - sample variance  of the input vector x
c .              note: if xmean and/or xvar = xmsg this routine will
c .                    calculate the quantities and return them
c .   mxlag    - max lag to be estimated  [0 <= mxlag <= npts ]
c .   acv      - sample autocovariances  [vector of length .ge. (mxlag+1) ]
c .   acr      - sample autocorrelations [vector of length .ge. (mxlag+1) ]

c .              acv(0)     = xvar (lag 0  )  : acr(0)       = 1.00 ( lag 0  )
c .              acv(1)     =      (lag 1  )  : acr(1)       =      ( lag 1  )
c .                         .                              .
c .                         .                              .
c .              acv(mxlag) =      (lag mxlag): acr(mxlag) =      ( lag mxlag)

c .   ier      - if (ier.ne.0) an error has occurred

c note :  uncalculated quantities are set to xmsg

      real x(1:npts) , acv(0:mxlag) , acr(0:mxlag)
      double precision x1

      ier = 0
      if (npts.lt.2) ier = 1
      if (mxlag.lt.0 .or. mxlag.gt.npts) ier = 2
      if (xvar .le.0. .and. xvar .ne.xmsg)    ier = 3
      if (ier.ne.0) then
          do lag=0,max0 (0, min0(mxlag,npts) )
             acv(lag) = xmsg
             acr(lag) = xmsg
          enddo
          return
      endif

      if (xmean.eq.xmsg .or. xvar.eq.xmsg) then
         call stat2 (x,npts,xmsg,xmean,xvar,xsd,nptused,jer)
         if (jer.ne.0) then
             ier = -jer
             return
         elseif (xvar.eq.0.) then
             ier = -5
             return
         endif
      endif

      acv(0) = xvar
      acr(0) = 1.00

      if (mxlag.eq.0) return       ! i hope somebody wants more than this

      do lag=1,mxlag
         x1 = 0.d0
         xn = 0.
       do n=1,npts-lag
          if (x(n).ne.xmsg .and. x(n+lag).ne.xmsg) then
              x1 = x1 + dprod( (x(n+lag)-xmean) , (x(n)-xmean) )
              xn = xn + 1.
          endif
       enddo
         if (xn.ge.2.) then
             acv(lag) = sngl(x1/dble(xn-1.))
             acr(lag) = acv(lag)/xvar
         else
             acv(lag) = xmsg
             acr(lag) = xmsg
         endif
      enddo

      return
      end
c ----------------------------------------------------------------------
      subroutine escros (x,y,npts,xmsg,ymsg,xmean,ymean,xsd,ysd
     1                  ,mxlag,ccv,ccr,ier)

c this routine will estimate the crosscovariances and crosscorrelations
c .   for the input series x and y. missing data is allowed.

c .   to get the (+) and (-) ccv and ccr two calls must be made. the
c .   first with the calling sequence above and the second with the
c .   x and y series reversed (also the other arguments) . note
c .   that  the second ccv(0) and ccr(0) are redundant.

c arguments :
c .   x,y      - input vectors with which the calculations are to take place.
c .   npts     - length of vectors x and y
c .   xmsg,ymsg- missing code: if no msg values set to some number
c .                            which will not be encountered.
c .              xmsg will be used to fill missing values
c .   xmean    - mean of the x vector (if xmean=xmsg: program will calculate)
c .   ymean    - mean of the y vector (if ymean=ymsg: program will calculate)
c .   xsd      - st. dev. of x vector (if xsd  =xmsg: program will calculate)
c .   ysd      - st. dev. of y vector (if ysd  =ymsg: program will calculate)
c .   mxlag    - max lag crosscovariance/correlation to be estimated
c .   ccv      - vector of length .ge. (mxlag+1) containing sample cross cov
c .   ccr      - vector of length .ge. (mxlag+1) containing sample cross cor

c .                ccv(0)     = xyvar (lag 0  )  : ccr(0)     =  ( lag 0   )
c .                ccv(1)     =       (lag 1  )  : ccr(1)     =  ( lag 1   )
c .                           .                               .
c .                           .                               .
c .                ccv(mxlag) =       (lag mxlag): ccr(mxlag) =  ( lag mxlag)

c .   ier      - if (ier.ne.0) an error has occurred

c note : uncalculated quantities are set to xmsg

      real x(1:npts) , y(1:npts) , ccv(0:mxlag) , ccr(0:mxlag)
      double precision xy1

      ier = 0
      if (npts.lt.2) ier = 1
      if (mxlag.lt.0 .or. mxlag.gt.npts) ier = 2
      if ((xsd.ne.xmsg .and. xsd.le.0.) .or.
     *    (ysd.ne.ymsg .and. ysd.le.0.)) ier = 3
      do lag=0,max0( 0, min0(mxlag,npts) )
         ccv(lag) = xmsg
         ccr(lag) = xmsg
      enddo
      if (ier.ne.0) return

      if (xmean.eq.xmsg .or. xsd.eq.xmsg) then
         call stat2 (x,npts,xmsg,xmean,xvar,xsd,nptused,jer)
         if (jer.ne.0) then
             ier = -jer
         elseif (xsd.eq.0.) then
             ier = -5              ! x must be a series of constant values
         elseif (nptused.eq.0) then
             ier = -6              ! x must be a series of missing values
         endif
         if (ier.ne.0) return
      endif

      if (ymean.eq.ymsg .or. ysd.eq.ymsg) then
         call stat2 (y,npts,ymsg,ymean,yvar,ysd,nptused,jer)
         if (jer.ne.0) then
             ier = -(jer+100)
         elseif (ysd.eq.0.) then
             ier = -105            ! y must be a series of constant values
         elseif (nptused.eq.0) then
             ier = -106            ! y must be a series of missing values
         endif
         if (ier.ne.0) return
      endif

      xsdysd = sngl(1.d0/dprod(xsd,ysd))

      do lag=0,mxlag
         xyn = 0.
         xy1 = 0.d0
       do n=1,npts-lag
          if (x(n).ne.xmsg .and. y(n+lag).ne.ymsg) then
              xy1 = xy1 + dprod((y(n+lag)-ymean),(x(n)-xmean))
              xyn = xyn + 1.
          endif
       enddo
         if (xyn.ge.2.) then
             ccv(lag) = sngl(xy1/dble(xyn-1.))
             ccr(lag) = ccv(lag)*xsdysd
         else
             ccv(lag) = xmsg
             ccr(lag) = xmsg
         endif
      enddo

      return
      end
c ----------------------------------------------------------------------
      subroutine rmvave  (x,npts,xmsg,xmean,ier)

c this routine will remove the mean of vector x from each pt.
c .   missing pts are excepted.

c arguments :
c .   x        - input vector
c .   npts     - length of x
c .   xmsg     - missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.
c .   xmean    - mean of the input vector (x)
c .   ier      - if (ier.ne.0) an error has occurred

      real x(1:npts)

      if (npts.lt.1) then
          ier = 1
          return
      else
          ier = 0
      endif

      do n=1,npts
         if (x(n).ne.xmsg) x(n) = x(n) - xmean
      enddo

      return
      end
c ----------------------------------------------------------
      subroutine stndx (x,npts,xmsg,xmean,xsd,ier)

c standardize the vector x

c arguments :
c .   x        - vector to be standardized
c .   npts     - length of vector x
c .   xmsg     - missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.
c .   xmean    - mean of the input vector
c .   xsd      - standard deviation of the series
c .   ier      - if (ier.ne.0) an error has ocurred

      real x(1:npts)

      ier = 0
      if (npts.lt.1) then
          ier = 1
      elseif (xsd.le.0.) then
          ier = 2
      endif
      if (ier.ne.0) return

      do n=1,npts
         if (x(n).ne.xmsg) x(n) = (x(n)-xmean)/xsd
      enddo

      return
      end
c ----------------------------------------------------------------------
      subroutine nmdata (x,npts,xmsg,ier)

c normalize the vector x by the absolute value of its largest element

c arguments :
c .   x        - series (vector) to be normalized
c .   npts     - length of x
c .   xmsg     - missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.
c .   ier      - if (ier.ne.0) an error has occurred

      real x(1:npts)

      ier = 0
      if (npts.lt.1) then
          ier = 1
          return
      endif

c find the first non-missing pt

      do n=1,npts
      if (x(n).ne.xmsg) then
          nstrt = n
          go to 20
      endif
      enddo

      ier = 1      ! must be all msg values
      return

   20 xmax = abs( x(nstrt) )
      do n=nstrt,npts
         if (x(n).ne.xmsg) xmax = amax1( abs(x(n)) , xmax )
      enddo

      if (xmax.ne.0.) then
          do n=nstrt,npts
             if (x(n).ne.xmsg) x(n) = x(n)/xmax
          enddo
      else
          ier = 2 ! must be all zeros
      endif

      return
      end
c ----------------------------------------------------------------------
      subroutine errchk (x,npts,xmean,xsd,xmsg,xband,locerr,npter,ier)

c this routine will check a series of data for potential gross errors
c .   (i.e., wild points). the series will be scanned and the locations
c .   of possibly bad points are stored. this routine
c .   assumes that the series x is normally distributed.

c input arguments:
c .   x        - series (vector) to be checked
c .   npts     - length of x
c .   xmean    - series mean (... or median is the user chooses)
c .   xsd      - series standard deviation
c .   xmsg     - missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.
c .   xband    - standard deviation width to be allowed
c .              (e.g., xband=3.0; check values beyond 99%)

c output arguments:
c .   locerr   - integer vector which will contain the subscript location of
c .              potential gross errors. for example: if series x has
c .              two pts more than xband from xmean and these pts are
c .              located at x(17) and x(204) then locerr(1) = 17 and
c .              locerr(2) = 204.
c .   npter    - no. of pts in locerr. in the above example it would be
c .              two. if a value of zero is returned no gross errors
c .              have been detected.
c .   ier      - if (ier.ne.0) an error has occurred

      real    x(1:npts)
      integer locerr(1:npts)

      ier = 0
      if (npts.lt.1) then
          ier = 1
      elseif (xsd.eq.0.) then
          ier = 2
      endif
      if (ier.ne.0) return

      nn     = 0
      npter  = 0
      xwidth = xband*xsd
      do n=1,npts
         if (x(n).ne.xmsg .and. abs(x(n)-xmean).gt.xwidth) then
             npter         = npter+1   ! must be a potential gross error
             locerr(npter) = n
         endif
      enddo

      return
      end
c ----------------------------------------------------------------------
      subroutine dotpr (x,y,npts,xmsg,ymsg,ans,nptused,ier)

c compute the dot product for series containing msg values

c arguments :
c .   x,y       - input series
c .   npts      - length of x and y
c .   xmsg,ymsg - missing code: if there are no msg values
c .                             set xmsg,ymsg to some value which will
c .                             not be encountered.
c .   ans       - answer (dot product)
c .   nptused   - number of points used to compute the dot product
c .   ier       - if (ier.ne.0) an error has occurred

      dimension x(1:npts) , y(1:npts)
      double precision temp

      ier = 0
      if (npts.lt.1) then
          ier = 1
          return
      endif

      temp    = 0.d0
      nptused = 0
      do n=1,npts
         if (x(n).ne.xmsg .and. y(n).ne.ymsg ) then
             temp    = temp + dprod( x(n),y(n) )
             nptused = nptused + 1
         endif
      enddo

      ans = sngl(temp)

      return
      end
c ----------------------------------------------------------------------
      subroutine vcvmns (x,nrow,ncol,nrt,ncs,xmsg,vcm,lvcm,ier)

c this routine will calculate the variance-covariance matrix (vcm)
c .   of the array x containing missing data. obviously if x does contain
c .   missing data then vcm is only an approximation.

c note : conventional storage is utilized for vcm

c     x        - input data array  ( unchanged on output)
c     nrow,ncol- exact dimensions of x in calling routine
c     nrt,ncs  - dimension of sub-matrix which contains the data
c                (nrt@nrow : ncs@ncol)
c     xmsg     - missing data code (if none set to some no. not encountered)
c     vcm      - var-cov matrix
c     lvcm     - not used in this routine
c     ier      - error code (if ier=-1 then vcm contains missing entry)

      real x(1:nrow,1:ncol) , vcm(1:ncol,1:ncol)
      double precision xca, xcb, xcacb

      ier=0

c calculate the var-cov between columns (stations)

      do nca=1,ncs
       do ncb=nca,ncs
          xn    = 0.
          xca   = 0.
          xcb   = 0.
          xcacb = 0.
        do i=1,nrt
           if (x(i,nca).ne.xmsg .and. x(i,ncb).ne.xmsg) then
               xn    = xn  + 1.
               xca   = xca + dble(x(i,nca))
               xcb   = xcb + dble(x(i,ncb))
               xcacb = xcacb + dprod( x(i,nca),x(i,ncb) )
           endif
        enddo    ! end "nrt"
          if (xn.ge.2.) then
              vcm(nca,ncb)= sngl((xcacb-(xca*xcb)/dble(xn))/dble(xn-1.))
              vcm(ncb,nca)= vcm(nca,ncb)
          else
              ier = -1
              vcm(nca,ncb) = xmsg
              vcm(ncb,nca) = xmsg
          endif
       enddo     ! end "ncs"
      enddo      ! end "ncs"

      return
      end
c ----------------------------------------------------------------------
      subroutine vcmssm (x,nrow,ncol,nrt,ncs,xmsg,vcm,lvcm,ier)

c this routine will calculate the variance-couariance matrix (vcm)
c .   of the array x containing missing data. obviously if x does contain
c .   missing data then vcm is only an approximation.

c note : symmetric storage mode is utilized for vcm to save space.

c input:
c     x        - input data array  ( unchanged on output)
c     nrow,ncol- exact dimensions of x in calling routine
c     nrt,ncs  - dimension of sub-matrix which contains the data
c                (nrt <= nrow : ncs <= ncol)
c     xmsg     - missing data code (if none set to some no. not encountered)
c output:
c     vcm      - var-cov matrix
c     lvcm     - length of vcm
c     ier      - error code (if ier=-1 then vcm contains missing entry)

      dimension x(1:nrow,1:ncol) , vcm(*)
      double precision xca, xcb, xcacb

      ier  = 0
      if (nrow.lt.1 .or. ncol.lt.1) ier = ier+1
      if (nrt .lt.1 .or. ncs .lt.1) ier = ier+10
      if (ier.ne.0) return

      lvcm = ncs*(ncs+1)/2

c calculate the var-cov between columns (stations)

      nn = 0
      do nca=1,ncs
       do ncb=1,nca
          xn    = 0.
          xca   = 0.d0
          xcb   = 0.d0
          xcacb = 0.d0
          nn    = nn + 1
        do i=1,nrt
           if (x(i,nca).ne.xmsg .and. x(i,ncb).ne.xmsg) then
               xn    = xn + 1.
               xca   = xca + dble(x(i,nca))
               xcb   = xcb + dble(x(i,ncb))
               xcacb = xcacb + dprod( x(i,nca) , x(i,ncb) )
           endif
        enddo
          if (xn.ge.2.) then
              vcm(nn) = sngl( (xcacb-(xca*xcb)/dble(xn) )/dble(xn-1.))
          elseif (xn.eq.1.) THEN
             vcm(nn) = ( xcacb-(xca*xcb)/xn )
          else
              ier     = -1
              vcm(nn) = xmsg
          endif
       enddo
      enddo

      return
      end
c
c ----------------------------------------------------------------------
      subroutine cormns (x,nrow,ncol,nrt,ncs,xmsg,crm,lcrm,ier)

c this routine will calculate the correlation matrix   (crm)
c .   of the array x containing missing data. obviously if x does contain
c .   missing data then crm is only an approximation.

c note : conventional storage

c     x        - input data array  ( unchanged on output)
c     nrow,ncol- exact dimensions of x in calling routine
c     nrt,ncs  - dimension of sub-matrix which contains the data
c                (nrt@nrow : ncs@ncol)
c     xmsg     - missing data code (if none set to some no. not encountered)
c     crm      - correlation matrix  [full]
c     lcrm     - dummy [not used in this routine]
c     ier      - error code (if ier=-1 then crm contains missing entry)

      real x(1:nrow,1:ncol) , crm(1:ncol,1:ncol)
      double precision xca, xcb, xca2, xcb2, xcacb, xvara, xvarb, temp

      ier  = 0
      lcrm = ncs*(ncs+1)/2

c calculate the var-cov between columns (stations)
c .   then standardize

      do nca=1,ncs
       do ncb=1,nca
          xn    = 0.
          xca   = 0.d0
          xcb   = 0.d0
          xca2  = 0.d0
          xcb2  = 0.d0
          xcacb = 0.d0
        do i=1,nrt
           if (x(i,nca).ne.xmsg .and. x(i,ncb).ne.xmsg) then
               xn    = xn + 1.
               xca   = xca + dble(x(i,nca))
               xcb   = xcb + dble(x(i,ncb))
               xca2  = xca2 + dprod(x(i,nca),x(i,nca))
               xcb2  = xcb2 + dprod(x(i,ncb),x(i,ncb))
              xcacb = xcacb + dprod(x(i,nca),x(i,ncb))
          endif
        enddo
          if (xn.ge.2.) then
              xvara   =  ( xca2-((xca*xca)/dble(xn)) )/dble(xn-1.)
              xvarb   =  ( xcb2-((xcb*xcb)/dble(xn)) )/dble(xn-1.)
              if (xvara.gt.0. .and. xvarb.gt.0.) then
                  temp  = (xcacb-((xca*xcb)/dble(xn)))/dble(xn-1.)
                  crm(ncb,nca) = sngl(temp/(dsqrt(xvara)*dsqrt(xvarb)))
                  crm(nca,ncb) = crm(ncb,nca) ! symmetric
              else
                  ier     = -1
                  crm(ncb,nca) = xmsg
                  crm(nca,ncb) = xmsg
              endif
          else
              ier     = -1
              crm(ncb,nca) = xmsg
              crm(nca,ncb) = xmsg
          endif
       enddo
      enddo

      return
      end
c ----------------------------------------------------------------------
      subroutine crmssm (x,nrow,ncol,nrt,ncs,xmsg,crm,lcrm,ier)

c this routine will calculate the correlation matrix   (crm)
c .   of the array x containing missing data. obviously if x does contain
c .   missing data then crm is only an approximation.

c note : symmetric storage mode is utilized for crm to save space.

c input:
c     x        - input data array  ( unchanged on output)
c     nrow,ncol- exact dimensions of x in calling routine
c     nrt,ncs  - dimension of sub-matrix which contains the data
c                (nrt <= nrow : ncs <= ncol)
c     xmsg     - missing data code (if none set to some no. not encountered)
c output:
c     crm      - correlation matrix
c     lcrm     - length of crm
c     ier      - error code (if ier=-1 then crm contains missing entry)

      real x(1:nrow,1:ncol) , crm(*)
      double precision xca, xcb, xca2, xcb2, xcacb, xvara, xvarb, temp

      ier  = 0
      if (nrow.lt.1 .or. ncol.lt.1) ier = ier+1
      if (nrt .lt.1 .or. ncs .lt.1) ier = ier+10
      if (ier.ne.0) return

      lcrm = ncs*(ncs+1)/2

c calculate the var-cov between columns (stations)

      nn   = 0
      do nca=1,ncs
       do ncb=1,nca
          xn    = 0.
          xca   = 0.d0
          xcb   = 0.d0
          xca2  = 0.d0
          xcb2  = 0.d0
          xcacb = 0.d0
          nn    = nn + 1
        do i=1,nrt
           if (x(i,nca).ne.xmsg .and. x(i,ncb).ne.xmsg) then
               xn    = xn + 1.
               xca   = xca   + dble(x(i,nca))
               xcb   = xcb   + dble(x(i,ncb))
               xca2  = xca2  + dprod(x(i,nca),x(i,nca))
               xcb2  = xcb2  + dprod(x(i,ncb),x(i,ncb))
               xcacb = xcacb + dprod(x(i,nca),x(i,ncb))
           endif
        enddo
          if (xn.ge.2.) then
              xvara   =  ( xca2-((xca*xca)/dble(xn)) )/dble(xn-1.)
              xvarb   =  ( xcb2-((xcb*xcb)/dble(xn)) )/dble(xn-1.)
              if (xvara.gt.0.d0 .and. xvarb.gt.0.d0) then
                  temp    = ( xcacb-((xca*xcb)/dble(xn)) )/dble(xn-1.)
                  crm(nn) = sngl( temp/(dsqrt(xvara)*dsqrt(xvarb)) )
              else
                  ier     = -1
                  crm(nn) = xmsg
              endif
           elseif (xn.eq.1.) then
              xvara   =  ( xca2-((xca*xca)/(xn)) )
              xvarb   =  ( xcb2-((xcb*xcb)/(xn)) )
              if (xvara.gt.0. .and. xvarb.gt.0.) then
                  crm(nn) = ( xcacb-((xca*xcb)/(xn)) )
                  crm(nn) = crm(nn)/(sqrt(xvara)*sqrt(xvarb))
              else
                  ier     = -1
                  crm(nn) = xmsg
              endif
          else
              ier     = -1
              crm(nn) = xmsg
          endif
       enddo
      enddo

      return
      end

c ----------------------------------------------------------------------
      subroutine ccorc (y,x,nrow,ncol,nrt,ncs,xmsg,corc,ier)

c this routine will calculate the correlation coef between a
c .   vector (station) y and a matrix x containing observations from
c .   many different stations

c     y        - vector (station data) with which data matrix x is to
c                be correlated
c     x        - input data array  ( unchanged on output)
c     nrow,ncol- exact dimensions of x in calling routine
c     nrt,ncs  - dimension of sub-matrix which contains the data
c                (nrt@nrow : ncs@ncol)
c     xmsg     - missing data code (if none set to some no. not encountered)
c     corc     - correlation coef. vector
c                corc(1) contain correlation coef between y and x(nrt,1)
c                corc(2) contain correlation coef between y and x(nrt,2) etc.
c     ier      - error code (if ier=-1 then corc contains missing entry)

      real x(1:nrow,1:ncol) , y(*) , corc(*)
      double precision xy, temp

c calculate the mean and var of y

      call stat2 (y,nrt,xmsg,ymean,yvar,ysd,nptusy,ier)
      if (ier.ne.0) return
      if (ysd .eq.0.) then
          do nc=1,ncs
             corc(nc) = xmsg
          enddo
          ier = 201
          return
      endif

c calculate the cross correlation coef
c .   calculate the mean and variance of column nc in the data array

      do nc=1,ncs
         corc(nc) = xmsg
         call stat2 (x(1,nc),nrt,xmsg,xmean,xvar,xsd,nptusx,jer)
         if (jer.ne.0) then
             ier = 205
             go to 40
         endif
         if (xsd.ne.0.) then
             xn = 0.
             xy = 0.d0
             do n=1,nrt
                if (y(n).ne.xmsg .and. x(n,nc).ne.xmsg) then
                    xn = xn + 1.
                    xy = xy + dprod( (y(n)-ymean),(x(n,nc)-xmean) )
               endif
             enddo
             if (xn.gt.2.) then
                 temp     = xy/dble(xn-1.)
                 corc(nc) = sngl(temp/dprod(xsd,ysd))
             endif
         endif
   40    continue
      enddo

      return
      end
c ------------------------------------------------------------------------------
      subroutine ssmiox (x,ncs)

c output a symmetric storage mode matrix [x]

c note: format statement have to be changed

c .   x(1)
c .   x(2)  x(3)
c .   x(4)  x(5)  x(6)
c .   etc.

      real x(1:*)

      data ipr/6/

      ncend=0
      do nc=1,ncs
         ncstrt = ncend+1
         ncend  = ncstrt+nc-1
         write(ipr,'(2x,i5,10(1x,f12.3),/, (7x,(10(1x,f12.3))))')
     *               nc,(x(n),n=ncstrt,ncend)
      enddo

      return
      end
c ------------------------------------------------------------
      real function epsmach (ipr)

      integer ipr    ! =1 print else no print
      real    eps

      eps = 1.0
    1 eps = 0.5*eps
      if ((1.0+eps) .gt. 1.0) go to 1
      epsmach = 2.0*eps
      if (ipr.eq.1) write (*,"('EPSMACH: eps=',e15.7)") epsmach

      return
      end

c ----------------------------------------------------------------------
      subroutine sortu  (a,la)                                          0340

c sort type "real"

      integer            la                                             0360
      real               a(la)                                          0370

      integer            iu(21),il(21),i,m,j,k,ij,l                     0390
      real               t,tt,r                                         0400

      m=1                                                               0420
      i=1                                                               0430
      j=la                                                              0440
      r=.375                                                            0450
      if (la.le.0) return                                               0460
   10 if (i .eq. j) go to 55                                            0470
   15 if (r .gt. .5898437) go to 20                                     0480
      r=r+3.90625e-2                                                    0490
      go to 25                                                          0500
   20 r=r-.21875                                                        0510
   25 k=i                                                               0520
c                                  select a central element of the      0530
c                                  array and save it in location t      0540
      ij=i+(j-i)*r                                                      0550
      t=a(ij)                                                           0560
c                                  if first element of array is greater 0570
c                                  than t, interchange with t           0580
      if (a(i) .le. t) go to 30                                         0590
      a(ij)=a(i)                                                        0600
      a(i)=t                                                            0610
      t=a(ij)                                                           0620
   30 l=j                                                               0630
c                                  if last element of array is less than0640
c                                  t, interchange with t                0650
      if (a(j) .ge. t) go to 40                                         0660
      a(ij)=a(j)                                                        0670
      a(j)=t                                                            0680
      t=a(ij)                                                           0690
c                                  if first element of array is greater 0700
c                                  than t, interchange with t           0710
      if (a(i) .le. t) go to 40                                         0720
      a(ij)=a(i)                                                        0730
      a(i)=t                                                            0740
      t=a(ij)                                                           0750
      go to 40                                                          0760
   35 if(a(l).eq.a(k)) go to 40                                         0770
      tt=a(l)                                                           0780
      a(l)=a(k)                                                         0790
      a(k)=tt                                                           0800
c                                  find an element in the second half of0810
c                                  the array which is smaller than t    0820
   40 l=l-1                                                             0830
      if (a(l) .gt. t) go to 40                                         0840
c                                  find an element in the first half of 0850
c                                  the array which is greater than t    0860
   45 k=k+1                                                             0870
      if (a(k) .lt. t) go to 45                                         0880
c                                  interchange these elements           0890
      if (k .le. l) go to 35                                            0900
c                                  save upper and lower subscripts of   0910
c                                  the array yet to be sorted           0920
      if (l-i .le. j-k) go to 50                                        0930
      il(m)=i                                                           0940
      iu(m)=l                                                           0950
      i=k                                                               0960
      m=m+1                                                             0970
      go to 60                                                          0980
   50 il(m)=k                                                           0990
      iu(m)=j                                                           1000
      j=l                                                               1010
      m=m+1                                                             1020
      go to 60                                                          1030
c                                  begin again on another portion of    1040
c                                  the unsorted array                   1050
   55 m=m-1                                                             1060
      if (m .eq. 0) return                                              1070
      i=il(m)                                                           1080
      j=iu(m)                                                           1090
   60 if (j-i .ge. 11) go to 25                                         1100
      if (i .eq. 1) go to 10                                            1110
      i=i-1                                                             1120
   65 i=i+1                                                             1130
      if (i .eq. j) go to 55                                            1140
      t=a(i+1)                                                          1150
      if (a(i) .le. t) go to 65                                         1160
      k=i                                                               1170
   70 a(k+1)=a(k)                                                       1180
      k=k-1                                                             1190
      if (t .lt. a(k)) go to 70                                         1200
      a(k+1)=t                                                          1210
      go to 65                                                          1220
      end                                                               1230
c ----------------------------------------------------------------------
      subroutine isortu  (a,la)

c sort type "integer"

      integer            la
      integer            a(la)

      integer            iu(21),il(21),i,m,j,k,ij,l
      integer            t,tt
      real               r

      m=1
      i=1
      j=la
      r=.375
      if (la.le.0) return
   10 if (i .eq. j) go to 55
   15 if (r .gt. .5898437) go to 20
      r=r+3.90625e-2
      go to 25
   20 r=r-.21875
   25 k=i
c                                  select a central element of the
c                                  array and save it in location t
      ij=i+(j-i)*r
      t=a(ij)
c                                  if first element of array is greater
c                                  than t, interchange with t
      if (a(i) .le. t) go to 30
      a(ij)=a(i)
      a(i)=t
      t=a(ij)
   30 l=j
c                                  if last element of array is less than
c                                  t, interchange with t
      if (a(j) .ge. t) go to 40
      a(ij)=a(j)
      a(j)=t
      t=a(ij)
c                                  if first element of array is greater
c                                  than t, interchange with t
      if (a(i) .le. t) go to 40
      a(ij)=a(i)
      a(i)=t
      t=a(ij)
      go to 40
   35 if(a(l).eq.a(k)) go to 40
      tt=a(l)
      a(l)=a(k)
      a(k)=tt
c                                  find an element in the second half of
c                                  the array which is smaller than t
   40 l=l-1
      if (a(l) .gt. t) go to 40
c                                  find an element in the first half of
c                                  the array which is greater than t
   45 k=k+1
      if (a(k) .lt. t) go to 45
c                                  interchange these elements
      if (k .le. l) go to 35
c                                  save upper and lower subscripts of
c                                  the array yet to be sorted
      if (l-i .le. j-k) go to 50
      il(m)=i
      iu(m)=l
      i=k
      m=m+1
      go to 60
   50 il(m)=k
      iu(m)=j
      j=l
      m=m+1
      go to 60
c                                  begin again on another portion of
c                                  the unsorted array
   55 m=m-1
      if (m .eq. 0) return
      i=il(m)
      j=iu(m)
   60 if (j-i .ge. 11) go to 25
      if (i .eq. 1) go to 10
      i=i-1
   65 i=i+1
      if (i .eq. j) go to 55
      t=a(i+1)
      if (a(i) .le. t) go to 65
      k=i
   70 a(k+1)=a(k)
      k=k-1
      if (t .lt. a(k)) go to 70
      a(k+1)=t
      go to 65
      end


!=====================================================================!
! Main Program for testing the integrators on different test problems
!=====================================================================!

#include "scalar.fpp"

program main

  use utils                         , only : real_part
  ! Import Integrators
  use runge_kutta_integrator        , only : DIRK
  use bdf_integrator                , only : BDF
  use abm_integrator                , only : ABM
  use nbg_integrator                , only : NBG

  ! Import physics
  use spring_mass_damper_class      , only : smd1

  ! Import functions
  use smd_functions_class           , only : kinetic_energy

  implicit none

  ! Declare integrators
  type(DIRK)                            :: dirkobj    ! DIRK Integrator object
  type(BDF)                             :: bdfobj     ! BDF Integrator object
  type(ABM)                             :: abmobj     ! ABM Integrator object
  type(NBG)                             :: nbgobj     ! NBM Integrator object

  ! Declare physics for testing
  type(smd1)                   , target :: smd1obj    ! Spring-mass-damper test ODE (1 var)

  ! Declare functions
  type(kinetic_energy)         , target :: KE

  ! Design variable array
  type(scalar), dimension(:), allocatable :: x, dfdx, dfdxtmp
  type(scalar)                            :: fval, ftmp

  ! Use different step sizes for real and complex mode arithmetic
#if defined USE_COMPLEX
  real(dp)                                :: dh = 1.0d-16
#else
  real(dp)                                :: dh = 1.0d-11
#endif

  allocate(X(3), dfdx(3), dfdxtmp(3))

  !===================================================================!
  !                       TEST ABM                                    !
  !===================================================================!

  X       = 0.0d0
  dfdx    = 0.0d0
  dfdxtmp = 0.0d0

  x(1) = 2.50d0   ! mass
  x(2) = 0.20d0    ! damping coeff
  x(3) = 5.0d0   ! stiffness coeff

  ! Initialize the system
  call smd1obj % initialize("SMD", num_state_vars = 1, num_design_vars = 3)
  abmobj = ABM(system = smd1obj, tfinal = 2.0d0, h=1.0d-3, max_abm_order = 6)
  call abmobj % evalFuncGrad(num_func=1, func = KE,  num_dv = 3, x = x, fvals = fval, dfdx= dfdx)
  call abmobj % writeSolution("abm.dat")
  call abmobj % evalFDFuncGrad(num_func=1, func = KE,  num_dv = 3, x = x, fvals = fval, dfdx= dfdxtmp, dh=dh)
  call abmobj % finalize()
  call smd1obj % finalize()

  print *, "fval         =", real_part(fval)
  print *, "Adjoint dfdx =", real_part(dfdx)
  print *, "FD      dfdx =", real_part(dfdxtmp)
  print *, "Error        =", abs(dfdxtmp-dfdx)
  print *, "Rel. Error   =", abs(real_part(dfdxtmp)-real_part(dfdx))/real_part(dfdxtmp)

  !===================================================================!
  !                       TEST NBG                                    !
  !===================================================================!

  fval = 0.0d0
  X       = 0.0d0
  dfdx    = 0.0d0
  dfdxtmp = 0.0d0

  x(1) = 2.50d0    ! mass
  x(2) = 0.20d0    ! damping coeff
  x(3) = 5.0d0    ! stiffness coeff

  ! Initialize the system
  call smd1obj % initialize("SMD", num_state_vars = 1, num_design_vars = 3)
  nbgobj = NBG(system = smd1obj, tfinal = 2.0d0, h=1.0d-3)
  call nbgobj % evalFuncGrad(num_func=1, func = KE,  num_dv = 3, x = x, fvals = fval, dfdx= dfdx)
  call nbgobj % writeSolution("nbg.dat")
  call nbgobj % evalFDFuncGrad(num_func=1, func = KE,  num_dv = 3, x = x, fvals = fval, dfdx= dfdxtmp, dh=dh)
  call nbgobj % finalize()
  call smd1obj % finalize()

  print *, "fval         =", real_part(fval)
  print *, "Adjoint dfdx =", real_part(dfdx)
  print *, "FD      dfdx =", real_part(dfdxtmp)
  print *, "Error        =", abs(dfdxtmp-dfdx)
  print *, "Rel. Error   =", abs(real_part(dfdxtmp)-real_part(dfdx))/real_part(dfdxtmp)

  !===================================================================!
  !                          TEST BDF                                 !
  !===================================================================!

  X       = 0.0d0
  dfdx    = 0.0d0
  dfdxtmp = 0.0d0

  x(1) = 2.50d0  ! mass
  x(2) = 0.20d0  ! damping coeff
  x(3) = 5.0d0   ! stiffness coeff

  ! Initialize the system
  call smd1obj % initialize("SMD", num_state_vars = 1, num_design_vars = 3)
  bdfobj = BDF(system = smd1obj, tfinal = 2.0d0, h=1.0d-3, max_bdf_order = 3)
  call bdfobj % evalFuncGrad(num_func=1, func = KE,  num_dv = 3, x = x, fvals = fval, dfdx= dfdx)
  call bdfobj % evalFDFuncGrad(num_func=1, func = KE,  num_dv = 3, x = x, fvals = fval, dfdx= dfdxtmp, dh=dh)
  call bdfobj % finalize()
  call smd1obj % finalize()

  print *, "fval         =", real_part(fval)
  print *, "Adjoint dfdx =", real_part(dfdx)
  print *, "FD      dfdx =", real_part(dfdxtmp)
  print *, "Error        =", abs(dfdxtmp-dfdx)
  print *, "Rel. Error   =", abs(real_part(dfdxtmp)-real_part(dfdx))/real_part(dfdxtmp)

  !===================================================================!
  !                          TEST DIRK                                !
  !===================================================================!

  X       = 0.0d0
  dfdx    = 0.0d0
  dfdxtmp = 0.0d0

  x(1) = 2.50d0  ! mass
  x(2) = 0.20d0  ! damping coeff
  x(3) = 5.0d0   ! stiffness coeff

  ! Initialize the system
  call smd1obj % initialize("SMD", num_state_vars = 1, num_design_vars = 3)
  dirkobj = DIRK(system = smd1obj, tfinal = 2.0d0, h=1.0d-3, num_stages=3, second_order=.true.)
  !  call dirkobj % testAdjointr( num_func = 1, func = KE, num_dv = 3, x = x,dfdx= dfdx)
  call dirkobj % testAdjoint6 ( num_func = 1, func = KE, num_dv = 3, &
       & x = x, dfdx= dfdx, dfdxtmp=dfdxtmp )

  !  call dirkobj % testAdjoint2( num_func = 1, func = KE, num_dv = 3, x = x,dfdx= dfdx)
  call dirkobj % writeSolution("dirksol.dat")

  !   call dirkobj % evalFuncGrad( num_func=1, func = KE, num_dv = 3, x = x, &
  !        & fvals = fval, dfdx= dfdx )

  call dirkobj % evalFDFuncGrad(num_func=1, func = KE, num_dv = 3, x = x, &
       & fvals = fval, dfdx= dfdxtmp, dh=dh)

  print *, "fval         =", real_part(fval)
  print *, "Adjoint dfdx =", real_part(dfdx)
  print *, "FD      dfdx =", real_part(dfdxtmp)
  print *, "Error        =", abs(dfdxtmp-dfdx)
  print *, "Rel. Error   =", abs(real_part(dfdxtmp)-real_part(dfdx))/real_part(dfdxtmp)

!!$  call dirkobj % evalFuncGrad(num_func=1, func = KE, num_dv = 3, x = x, &
!!$       & fvals = fval, dfdx= dfdx)
!!$
!!$  call dirkobj % writeSolution("dirksol.dat")
!!$
!!$  call dirkobj % evalFDFuncGrad(num_func=1, func = KE, num_dv = 3, x = x, &
!!$       & fvals = fval, dfdx= dfdxtmp, dh=dh)

  call dirkobj % finalize()
  call smd1obj % finalize()

  deallocate(X, dfdx, dfdxtmp)

end program main


!-------------------------------------------------------------------------------!
!                                                                               !

subroutine marquardt(model,term,x,xn,bl,bu,n,y,w,m)

!  Marquardt's method for least squares                                         !
!  Find x that minimizes F(x) = 0.5*sum_{i=1}^m (f_i(x1,x2,..,xn)^2)            !
!  under box constraints bl(i) <= xi <= bu(i), i = 1,2,...,n                    !
!                                                                               !
!  Refs:                                                                        !
!  Hans Bruun Nielsen, IMM, DTU, Denmark                                        !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 17/8-2005                                                            !
!                                                                               !
!  Variables                                                                    !
!  x(n)      row vector with parameter values                                   !
!  f(m)      row vector with function values                                    !
!  J(m,n)    Jacobian matrix                                                    !
!                                                                               !
!  Termination criteria                                                         !
!  term = 1  terminated by small gradient                                       !
!  term = 2  terminated by small x-step                                         !
!  term = 3  singular matrix, restart from current x with increased             !
!            value for mu                                                       !
!  term = 4  terminated by kmax                                                 !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer          :: m,n,i,jjj,k,kmax,term,model
double precision :: delta,x(n),xn(n),bl(n),bu(n),y(m),w(m),f(m),fn(m),J(m,n)
double precision :: Jn(m,n),eye(n,n),h(n),dL,g(n),F_,Fn_,dF,ng,mu,nu,nh,nx,A(n,n)

A = 0.d0
eye = 0.d0
do i = 1,n
  eye(i,i) = 1.d0
end do
kmax = 100                    ! 100
delta = 1.d-4                 ! 1.d-8
if (model == 1) then
  call fungauss(m,f,J,x,y,w)
else if (model == 2) then
  call funlogistic(m,f,J,x,y,w)
end if
A(1:n,1:n) = matmul(transpose(J),J)
g = matmul(f,J)
F_ = dot_product(f,f)/2.d0
ng = maxval(abs(g))
mu = 1.d0*maxval((/(A(i,i),i=1,n)/))
k = 1
nu = 2.d0
nh = 0.d0
term = 0

do while (term == 0)
  do i = 1,n
    do jjj = 1,n
      !if (isnan(A(i,jjj)) == .true.) then
       if (isnan(A(i,jjj))) then
	    write(*,*) 'NaN in marquardt'
		term = 99
		return
	  end if
	end do
  end do
  if (ng <= delta) then
    term = 1
  else
    call gauss(n,A(1:n,1:n)+mu*eye,-g,h)
    nh = sqrt(dot_product(h,h))
    nx = delta + sqrt(dot_product(x,x))
    if (nh <= delta*nx .and. k > 1) then
      term = 2
    else if (nh >= nx/epsilon(1.d0)) then ! Almost singular, restart from current x with increased value for  mu .
      term = 3
	  write(*,*) 'stop in marquard'
	  stop
    end if
  end if
  if (term == 0) then
    xn = x + h

    where (xn < bl) xn = bl               ! Project onto the feasible parameter set
	where (xn > bu) xn = bu

    dL =  dot_product(h,mu*h-g)/2.d0
	if (model == 1) then
      call fungauss(m,fn,Jn,xn,y,w)
	else if (model == 2) then
	  call funlogistic(m,fn,Jn,xn,y,w)
	end if
    Fn_ = dot_product(fn,fn)/2.d0
    dF = F_ - Fn_
    if  ((dL > 0) .and. (dF > 0)) then    ! Update x and modify mu
      x = xn
      F_ = Fn_
      J = Jn
      f = fn
      A(1:n,1:n) = matmul(transpose(J),J)
	  g = matmul(f,J)
      ng = maxval(abs(g))
      mu = mu*max(1.d0/3.d0, 1 - (2.d0*dF/dL - 1.d0)**3.d0)
	  nu = 2.d0
    else                                  ! Same  x, increase  mu
	  mu = mu*nu
      nu = 2.d0*nu
    end if
    k = k + 1
    if  (k > kmax) then
      term = 4
    end if
  end if
end do

end subroutine marquardt


module advance_module

  use multifab_module
  use ml_layout_module
  use define_bc_module
  use bc_module
  use ml_restrict_fill_module
  use mg_module
  use bndry_reg_module
  use cc_stencil_fill_module
  use ml_solve_module

  implicit none

  private

  public :: advance

contains

  subroutine advance(mla,phi,dx,dt,the_bc_tower,do_implicit_solve)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi(:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: dt
    type(bc_tower) , intent(in   ) :: the_bc_tower
    logical        , intent(in   ) :: do_implicit_solve

    ! local variables
    integer i,dm,n,nlevs

    ! an array of multifabs; one for each direction
    type(multifab) :: flux(mla%nlevel,mla%dim)

    type(multifab) :: alpha(mla%nlevel)
    type(multifab) :: beta(mla%nlevel,mla%dim)
    type(multifab) :: rhs(mla%nlevel)

    type(bndry_reg) :: fine_flx(2:mla%nlevel)

    real(dp_t) :: dx_vector(mla%nlevel,mla%dim)

    integer :: bc_comp

    dm = mla%dim
    nlevs = mla%nlevel

    if (do_implicit_solve) then

       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       ! implicit time advancement
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

       ! Solve for phi using backward Euler discretization:
       ! (phi^n+1 - phi^n) / Delta t = lap phi^n+1.
       ! ml_cc_solve solves for phi in the equation:
       ! (alpha - del dot beta grad) phi = rhs,
       ! where alpha, phi, and rhs are cell-centered and beta is face-centered.
       ! The backward Euler discretization can be rewritten as:
       ! (I - Delta t * lap) phi^n+1 = phi^n
       ! thus,
       ! alpha = 1.0, beta = Delta t, and rhs = phi^n

       do n=1,nlevs

          ! set alpha=1
          call multifab_build(alpha(n),mla%la(n),1,0)
          call setval(alpha(n),1.d0,all=.true.)

          ! set beta=dt
          do i=1,dm
             call multifab_build_edge(beta(n,i),mla%la(n),1,0,i)
             call setval(beta(n,i), dt, all=.true.)
          end do

          ! copy phi into rhs
          call multifab_build(rhs(n),mla%la(n),1,0)
          call multifab_copy_c(rhs(n),1,phi(n),1,1,0)

       end do

       ! stores +beta*grad phi/dx_fine on low (relative to fine) coarse-fine interfaces
       ! stores -beta*grad phi/dx_fine on high coarse-fine interfaces
       ! this gets computed inside of ml_cc_solve
       ! we pass it back out because some algorithms (like projection methods)
       ! use this information
       do n = 2,nlevs
          call bndry_reg_build(fine_flx(n),mla%la(n),ml_layout_get_pd(mla,n))
       end do

       ! there is only one boundary condition component in this example
       bc_comp = 1

       ! ml_cc_solve interface requires dx dimensioned as dx(nlevs,dm)
       do n=1,nlevs
          dx_vector(n,1:dm) = dx(n)
       end do

       ! solve (alpha - del dot beta grad) phi = rhs to obtain phi
       call ml_cc_solve(mla,rhs,phi,fine_flx,alpha,beta,dx_vector,the_bc_tower,bc_comp)

       ! free memory
       do n = 2,nlevs
          call bndry_reg_destroy(fine_flx(n))
       end do
       do n = 1,nlevs
          call multifab_destroy(alpha(n))
          call multifab_destroy(rhs(n))
          do i=1,dm
             call multifab_destroy(beta(n,i))
          end do
       end do

    else

       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       ! explicit time advancement
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

       ! build the flux(:,:) multifabs
       do n=1,nlevs
          do i=1,dm
             ! flux(n,i) has one component, zero ghost cells, and is nodal in direction i
             call multifab_build_edge(flux(n,i),mla%la(n),1,0,i)
          end do
       end do

       ! compute the face-centered gradients in each direction
       call compute_flux(mla,phi,flux,dx,the_bc_tower)

       ! update phi using forward Euler discretization
       call update_phi(mla,phi,flux,dx,dt,the_bc_tower)

       ! make sure to destroy the multifab or you'll leak memory
       do n=1,nlevs
          do i=1,dm
             call multifab_destroy(flux(n,i))
          end do
       end do

    end if

  end subroutine advance

  subroutine compute_flux(mla,phi,flux,dx,the_bc_tower)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(in   ) :: phi(:)
    type(multifab) , intent(inout) :: flux(:,:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! local variables
    integer :: dm, ng_p, ng_f, i, n, nlevs

    dm    = mla%dim
    nlevs = mla%nlevel

    ng_p = phi(1)%ng
    ng_f = flux(1,1)%ng

    do n=1,nlevs

       call compute_flux_single_level(n,mla,phi,flux,dx,the_bc_tower)

    end do

    ! set level n-1 fluxes to be the average of the level n fluxes covering it
    ! the loop over nlevs must count backwards to make sure the finer grids are done first
    do n=nlevs,2,-1
       do i=1,dm
          call ml_edge_restriction_c(flux(n-1,i),1,flux(n,i),1,mla%mba%rr(n-1,:),i,1)
       end do
    end do

  end subroutine compute_flux

  subroutine compute_flux_single_level(n,mla,phi,flux,dx,the_bc_tower)

    integer        , intent(in   ) :: n
    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(in   ) :: phi(:)
    type(multifab) , intent(inout) :: flux(:,:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! local variables
    integer :: lo(mla%dim), hi(mla%dim)
    integer :: dm, ng_p, ng_f, i

    real(kind=dp_t), pointer ::  pp(:,:,:,:)
    real(kind=dp_t), pointer :: fxp(:,:,:,:)
    real(kind=dp_t), pointer :: fyp(:,:,:,:)
    real(kind=dp_t), pointer :: fzp(:,:,:,:)

    dm    = mla%dim

    ng_p = phi(1)%ng
    ng_f = flux(1,1)%ng

    do i=1,nfabs(phi(n))
       pp  => dataptr(phi(n),i)
       fxp => dataptr(flux(n,1),i)
       fyp => dataptr(flux(n,2),i)
       lo = lwb(get_box(phi(n),i))
       hi = upb(get_box(phi(n),i))
       select case(dm)
       case (2)
          call compute_flux_2d(pp(:,:,1,1), ng_p, &
                               fxp(:,:,1,1),  fyp(:,:,1,1), ng_f, &
                               lo, hi, dx(n), &
                               the_bc_tower%bc_tower_array(n)%adv_bc_level_array(i,:,:,1))
       case (3)
          fzp => dataptr(flux(n,3),i)
          call compute_flux_3d(pp(:,:,:,1), ng_p, &
                               fxp(:,:,:,1),  fyp(:,:,:,1), fzp(:,:,:,1), ng_f, &
                               lo, hi, dx(n), &
                               the_bc_tower%bc_tower_array(n)%adv_bc_level_array(i,:,:,1))
       end select
    end do

  end subroutine compute_flux_single_level

  subroutine compute_flux_2d(phi, ng_p, fluxx, fluxy, ng_f, lo, hi, dx, adv_bc)

    integer          :: lo(2), hi(2), ng_p, ng_f
    double precision ::   phi(lo(1)-ng_p:,lo(2)-ng_p:)
    double precision :: fluxx(lo(1)-ng_f:,lo(2)-ng_f:)
    double precision :: fluxy(lo(1)-ng_f:,lo(2)-ng_f:)
    double precision :: dx
    integer          :: adv_bc(:,:)

    ! local variables
    integer i,j

    ! x-fluxes
    do j=lo(2),hi(2)
       do i=lo(1),hi(1)+1
          fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / dx
       end do
    end do

    ! lo-x boundary conditions
    if (adv_bc(1,1) .eq. EXT_DIR) then
       i=lo(1)
       do j=lo(2),hi(2)
          ! divide by 0.5*dx since the ghost cell value represents
          ! the value at the wall, not the ghost cell-center
          fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / (0.5d0*dx)
       end do
    else if (adv_bc(1,1) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxx(lo(1),lo(2):hi(2)) = 0.d0
    end if

    ! hi-x boundary conditions
    if (adv_bc(1,2) .eq. EXT_DIR) then
       i=hi(1)+1
       do j=lo(2),hi(2)
          ! divide by 0.5*dx since the ghost cell value represents
          ! the value at the wall, not the ghost cell-center
          fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / (0.5d0*dx)
       end do
    else if (adv_bc(1,2) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxx(hi(1)+1,lo(2):hi(2)) = 0.d0
    end if

    ! y-fluxes
    do j=lo(2),hi(2)+1
       do i=lo(1),hi(1)
          fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / dx
       end do
    end do

    ! lo-y boundary conditions
    if (adv_bc(2,1) .eq. EXT_DIR) then
       j=lo(2)
       do i=lo(1),hi(1)
          ! divide by 0.5*dx since the ghost cell value represents
          ! the value at the wall, not the ghost cell-center
          fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / (0.5d0*dx)
       end do
    else if (adv_bc(2,1) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxy(lo(1):hi(1),lo(2)) = 0.d0
    end if

    ! hi-y boundary conditions
    if (adv_bc(2,2) .eq. EXT_DIR) then
       j=hi(2)+1
       do i=lo(1),hi(1)
          ! divide by 0.5*dx since the ghost cell value represents
          ! the value at the wall, not the ghost cell-center
          fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / (0.5d0*dx)
       end do
    else if (adv_bc(2,2) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxy(lo(1):hi(1),hi(2)+1) = 0.d0
    end if

  end subroutine compute_flux_2d

  subroutine compute_flux_3d(phi, ng_p, fluxx, fluxy, fluxz, ng_f, &
                             lo, hi, dx, adv_bc)

    integer          :: lo(3), hi(3), ng_p, ng_f
    double precision ::   phi(lo(1)-ng_p:,lo(2)-ng_p:,lo(3)-ng_p:)
    double precision :: fluxx(lo(1)-ng_f:,lo(2)-ng_f:,lo(3)-ng_f:)
    double precision :: fluxy(lo(1)-ng_f:,lo(2)-ng_f:,lo(3)-ng_f:)
    double precision :: fluxz(lo(1)-ng_f:,lo(2)-ng_f:,lo(3)-ng_f:)
    double precision :: dx
    integer          :: adv_bc(:,:)

    ! local variables
    integer i,j,k

    ! x-fluxes
    !$omp parallel do private(i,j,k)
    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)+1
             fluxx(i,j,k) = ( phi(i,j,k) - phi(i-1,j,k) ) / dx
          end do
       end do
    end do
    !$omp end parallel do

    ! lo-x boundary conditions
    if (adv_bc(1,1) .eq. EXT_DIR) then
       i=lo(1)
       !$omp parallel do private(j,k)
       do k=lo(3),hi(3)
          do j=lo(2),hi(2)
             ! divide by 0.5*dx since the ghost cell value represents
             ! the value at the wall, not the ghost cell-center
             fluxx(i,j,k) = ( phi(i,j,k) - phi(i-1,j,k) ) / (0.5d0*dx)
          end do
       end do
       !$omp end parallel do
    else if (adv_bc(1,1) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxx(lo(1),lo(2):hi(2),lo(3):hi(3)) = 0.d0
    end if

    ! hi-x boundary conditions
    if (adv_bc(1,2) .eq. EXT_DIR) then
       i=hi(1)+1
       !$omp parallel do private(j,k)
       do k=lo(3),hi(3)
          do j=lo(2),hi(2)
             ! divide by 0.5*dx since the ghost cell value represents
             ! the value at the wall, not the ghost cell-center
             fluxx(i,j,k) = ( phi(i,j,k) - phi(i-1,j,k) ) / (0.5d0*dx)
          end do
       end do
       !$omp end parallel do
    else if (adv_bc(1,2) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxx(hi(1)+1,lo(2):hi(2),lo(3):hi(3)) = 0.d0
    end if

    ! y-fluxes
    !$omp parallel do private(i,j,k)
    do k=lo(3),hi(3)
       do j=lo(2),hi(2)+1
          do i=lo(1),hi(1)
             fluxy(i,j,k) = ( phi(i,j,k) - phi(i,j-1,k) ) / dx
          end do
       end do
    end do
    !$omp end parallel do

    ! lo-y boundary conditions
    if (adv_bc(2,1) .eq. EXT_DIR) then
       j=lo(2)
       !$omp parallel do private(i,k)
       do k=lo(3),hi(3)
          do i=lo(1),hi(1)
             ! divide by 0.5*dx since the ghost cell value represents
             ! the value at the wall, not the ghost cell-center
             fluxy(i,j,k) = ( phi(i,j,k) - phi(i,j-1,k) ) / (0.5d0*dx)
          end do
       end do
       !$omp end parallel do
    else if (adv_bc(2,1) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxy(lo(1):hi(1),lo(2),lo(3):hi(3)) = 0.d0
    end if

    ! hi-y boundary conditions
    if (adv_bc(2,2) .eq. EXT_DIR) then
       j=hi(2)+1
       !$omp parallel do private(i,k)
       do k=lo(3),hi(3)
          do i=lo(1),hi(1)
             ! divide by 0.5*dx since the ghost cell value represents
             ! the value at the wall, not the ghost cell-center
             fluxy(i,j,k) = ( phi(i,j,k) - phi(i,j-1,k) ) / (0.5d0*dx)
          end do
       end do
       !$omp end parallel do
    else if (adv_bc(2,2) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxy(lo(1):hi(1),hi(2)+1,lo(3):hi(3)) = 0.d0
    end if

    ! z-fluxes
    !$omp parallel do private(i,j,k)
    do k=lo(3),hi(3)+1
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)
             fluxz(i,j,k) = ( phi(i,j,k) - phi(i,j,k-1) ) / dx
          end do
       end do
    end do
    !$omp end parallel do

    ! lo-z boundary conditions
    if (adv_bc(3,1) .eq. EXT_DIR) then
       k=lo(3)
       !$omp parallel do private(i,j)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)
             ! divide by 0.5*dx since the ghost cell value represents
             ! the value at the wall, not the ghost cell-center
             fluxz(i,j,k) = ( phi(i,j,k) - phi(i,j,k-1) ) / (0.5d0*dx)
          end do
       end do
       !$omp end parallel do
    else if (adv_bc(3,1) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxz(lo(1):hi(1),lo(2):lo(3),lo(3)) = 0.d0
    end if

    ! hi-z boundary conditions
    if (adv_bc(3,2) .eq. EXT_DIR) then
       k=hi(3)+1
       !$omp parallel do private(i,j)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)
             ! divide by 0.5*dx since the ghost cell value represents
             ! the value at the wall, not the ghost cell-center
             fluxz(i,j,k) = ( phi(i,j,k) - phi(i,j,k-1) ) / (0.5d0*dx)
          end do
       end do
       !$omp end parallel do
    else if (adv_bc(3,2) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxz(lo(1):hi(1),lo(2):hi(2),hi(3)+1) = 0.d0
    end if

  end subroutine compute_flux_3d

  subroutine update_phi(mla,phi,flux,dx,dt,the_bc_tower)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi(:)
    type(multifab) , intent(in   ) :: flux(:,:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: dt
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! local variables
    integer :: n, nlevs

    nlevs = mla%nlevel

    do n=1,nlevs

       call update_phi_single_level(n,mla,phi,flux,dx,dt)

    end do

    ! restrict the multi-level data, and
    ! fill all boundaries: same-level, coarse-fine, periodic, and domain boundaries
    call ml_restrict_and_fill(nlevs, phi, mla%mba%rr, the_bc_tower%bc_tower_array)

  end subroutine update_phi

  subroutine update_phi_single_level(n,mla,phi,flux,dx,dt)

    integer        , intent(in   ) :: n
    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi(:)
    type(multifab) , intent(in   ) :: flux(:,:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: dt

    ! local variables
    integer :: lo(mla%dim), hi(mla%dim)
    integer :: dm, ng_p, ng_f, i

    real(kind=dp_t), pointer ::  pp(:,:,:,:)
    real(kind=dp_t), pointer :: fxp(:,:,:,:)
    real(kind=dp_t), pointer :: fyp(:,:,:,:)
    real(kind=dp_t), pointer :: fzp(:,:,:,:)

    dm    = mla%dim

    ng_p = phi(1)%ng
    ng_f = flux(1,1)%ng

    do i=1,nfabs(phi(n))
       pp  => dataptr(phi(n),i)
       fxp => dataptr(flux(n,1),i)
       fyp => dataptr(flux(n,2),i)
       lo = lwb(get_box(phi(n),i))
       hi = upb(get_box(phi(n),i))
       select case(dm)
       case (2)
          call update_phi_2d(pp(:,:,1,1), ng_p, &
                             fxp(:,:,1,1), fyp(:,:,1,1), ng_f, &
                             lo, hi, dx(n), dt)
       case (3)
          fzp => dataptr(flux(n,3),i)
          call update_phi_3d(pp(:,:,:,1), ng_p, &
                             fxp(:,:,:,1), fyp(:,:,:,1), fzp(:,:,:,1), ng_f, &
                             lo, hi, dx(n), dt)
       end select
    end do

  end subroutine update_phi_single_level

  subroutine update_phi_2d(phi, ng_p, fluxx, fluxy, ng_f, lo, hi, dx, dt)

    integer          :: lo(2), hi(2), ng_p, ng_f
    double precision ::   phi(lo(1)-ng_p:,lo(2)-ng_p:)
    double precision :: fluxx(lo(1)-ng_f:,lo(2)-ng_f:)
    double precision :: fluxy(lo(1)-ng_f:,lo(2)-ng_f:)
    double precision :: dx, dt

    ! local variables
    integer i,j

    do j=lo(2),hi(2)
       do i=lo(1),hi(1)
          phi(i,j) = phi(i,j) + dt * &
               ( fluxx(i+1,j)-fluxx(i,j) + fluxy(i,j+1)-fluxy(i,j) ) / dx
       end do
    end do

  end subroutine update_phi_2d

  subroutine update_phi_3d(phi, ng_p, fluxx, fluxy, fluxz, ng_f, lo, hi, dx, dt)

    integer          :: lo(3), hi(3), ng_p, ng_f
    double precision ::   phi(lo(1)-ng_p:,lo(2)-ng_p:,lo(3)-ng_p:)
    double precision :: fluxx(lo(1)-ng_f:,lo(2)-ng_f:,lo(3)-ng_f:)
    double precision :: fluxy(lo(1)-ng_f:,lo(2)-ng_f:,lo(3)-ng_f:)
    double precision :: fluxz(lo(1)-ng_f:,lo(2)-ng_f:,lo(3)-ng_f:)
    double precision :: dx, dt

    ! local variables
    integer i,j,k

    !$omp parallel do private(i,j,k)
    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)
             phi(i,j,k) = phi(i,j,k) + dt * &
                  ( fluxx(i+1,j,k)-fluxx(i,j,k) &
                   +fluxy(i,j+1,k)-fluxy(i,j,k) &
                   +fluxz(i,j,k+1)-fluxz(i,j,k) ) / dx
          end do
       end do
    end do
    !$omp end parallel do

  end subroutine update_phi_3d

end module advance_module