djckf Subroutine

   subroutine djckf &
      (fcn, &
       n, m, np, nq, &
       beta, xplusd, ifixb, ifixx, ldifx, &
       eta, tol, nrow, j, lq, iswrtb, &
       fd, typj, pvpstp, stp0, curve, pv, d, &
       diffj, msg, istop, nfev, &
       wrk1, wrk2, wrk6)
   !! Check whether finite precision arithmetic could be the cause of the disagreement between
   !! the derivatives.
      ! Adapted from STARPAC subroutine DCKFPA.
      ! Routines Called  DPVB, DPVD
      ! Date Written   860529   (YYMMDD)
      ! Revision Date  920619   (YYMMDD)

      use odrpack_kinds, only: one, two, hundred

      procedure(fcn_t) :: fcn
         !! The user supplied subroutine for evaluating the model.
      integer, intent(in) :: n
         !! The number of observations.
      integer, intent(in) :: m
         !! The number of columns of data in the explanatory variable.
      integer, intent(in) :: np
         !! The number of function parameters.
      integer, intent(in) :: nq
         !! The number of responses per observation.
      real(wp), intent(inout) :: beta(np)
         !! The function parameters.
      real(wp), intent(inout) :: xplusd(n, m)
         !! The values of `x + delta`.
      integer, intent(in) :: ifixb(np)
         !! The values designating whether the elements of `beta` are fixed at their input values or not.
      integer, intent(in) :: ifixx(ldifx, m)
         !! The values designating whether the elements of `x` are fixed at their input values or not.
      integer, intent(in) :: ldifx
         !! The leading dimension of array `ifixx`.
      real(wp), intent(in) :: eta
         !! The relative noise in the model.
      real(wp), intent(in) :: tol
         !! The agreement tolerance.
      integer, intent(in) :: nrow
         !! The row number of the explanatory variable array at which the derivative is to be checked.
      integer, intent(in) :: j
         !! The index of the partial derivative being examined.
      integer, intent(in) :: lq
         !! The response currently being examined.
      logical, intent(in) :: iswrtb
         !! The variable designating whether the derivatives wrt `beta` (`iswrtb = .true.`)
         !! or `delta` (`iswrtb = .false.`) are being checked.
      real(wp), intent(out) :: fd
         !! The forward difference derivative wrt the `j`-th parameter.
      real(wp), intent(in) :: typj
         !! The typical size of the `j`-th unknown `beta` or `delta`.
      real(wp), intent(out) :: pvpstp
         !! The predicted value for row `nrow` of the model based on the current parameter
         !! estimates for all but the `j`-th parameter value, which is `beta(j) + stp0`.
      real(wp), intent(in) :: stp0
         !! The step size for the finite difference derivative.
      real(wp), intent(inout) :: curve
         !! A measure of the curvature in the model.
      real(wp), intent(in) :: pv
         !! The predicted value for row `nrow`.
      real(wp), intent(in) :: d
         !! The derivative with respect to the `j`-th unknown parameter.
      real(wp), intent(out) :: diffj
         !! The relative differences between the user supplied and finite difference derivatives
         !! for the derivative being checked.
      integer, intent(out) :: msg(nq, j)
         !! The error checking results.
      integer, intent(out) :: istop
         !! The variable designating whether there are problems computing the function at the
         !! current `beta` and `delta`.
      integer, intent(inout) :: nfev
         !! The number of function evaluations.
      real(wp), intent(out) :: wrk1(n, m, nq)
         !! A work array of `(n, m, nq)` elements.
      real(wp), intent(out) :: wrk2(n, nq)
         !! A work array of `(n, nq)` elements.
      real(wp), intent(out) :: wrk6(n, np, nq)
         !! A work array of `(n, np, nq)` elements.

      ! Local scalars
      real(wp), parameter :: p1 = 0.1_wp
      real(wp) :: stp
      logical :: large

      ! Variable Definitions (alphabetically)
      !  BETA:    The function parameters.
      !  CURVE:   A measure of the curvature in the model.
      !  D:       The derivative with respect to the Jth unknown parameter.
      !  DIFFJ:   The relative differences between the user supplied and finite difference
      !           derivatives for the derivative being checked.
      !  ETA:     The relative noise in the model.
      !  FCN:     The user supplied subroutine for evaluating the model.
      !  FD:      The forward difference derivative wrt the Jth parameter.
      !  IFIXB:   The values designating whether the elements of BETA are fixed at their input
      !           values or not.
      !  IFIXX:   The values designating whether the elements of X are fixed at their input values
      !           or not.
      !  ISTOP:   The variable designating whether there are problems computing the function at
      !           the current BETA and DELTA.
      !  ISWRTB:  The variable designating whether the derivatives wrt BETA (ISWRTB=TRUE) or
      !           DELTA(ISWRTB=FALSE) are being checked.
      !  J:       The index of the partial derivative being examined.
      !  LARGE:   The value designating whether the recommended increase in the step size would
      !           be greater than TYPJ.
      !  LDIFX:   The leading dimension of array IFIXX.
      !  LQ:      The response currently being examined.
      !  M:       The number of columns of data in the explanatory variable.
      !  MSG:     The error checking results.
      !  N:       The number of observations.
      !  NFEV:    The number of function evaluations.
      !  NP:      The number of function parameters.
      !  NQ:      The number of responses per observation.
      !  NROW:    The row number of the explanatory variable array at which the derivative is to
      !           be checked.
      !  PV:      The predicted value for row NROW.
      !  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 BETA(J) + STP0.
      !  P1:      The value 0.1E0_wp.
      !  STP0:    The step size for the finite difference derivative.
      !  TOL:     The agreement tolerance.
      !  TYPJ:    The typical size of the J-th unknown BETA or DELTA.
      !  WRK1:    A work array of (N BY M BY NQ) elements.
      !  WRK2:    A work array of (N BY NQ) elements.
      !  WRK6:    A work array of (N BY NP BY NQ) elements.
      !  XPLUSD:  The values of X + DELTA.

      ! Finite precision arithmetic could be the problem.
      ! Try a larger step size based on estimate of condition error.
      stp = eta*(abs(pv) + abs(pvpstp))/(tol*abs(d))
      if (stp > abs(p1*stp0)) then
         stp = max(stp, hundred*abs(stp0))
      end if
      if (stp > typj) then
         stp = typj
         large = .true.
      else
         large = .false.
      end if

      if (iswrtb) then
         ! Perform computations for derivatives wrt BETA
         stp = (stp*sign(one, beta(j)) + beta(j)) - beta(j)
         call dpvb(fcn, &
                   n, m, np, nq, &
                   beta, xplusd, ifixb, ifixx, ldifx, &
                   nrow, j, lq, stp, &
                   istop, nfev, pvpstp, &
                   wrk1, wrk2, wrk6)
      else
         ! Perform computations for derivatives wrt DELTA
         stp = (stp*sign(one, xplusd(nrow, j)) + xplusd(nrow, j)) - xplusd(nrow, j)
         call dpvd(fcn, &
                   n, m, np, nq, &
                   beta, xplusd, ifixb, ifixx, ldifx, &
                   nrow, j, lq, stp, &
                   istop, nfev, pvpstp, &
                   wrk1, wrk2, wrk6)
      end if
      if (istop /= 0) then
         return
      end if

      fd = (pvpstp - pv)/stp
      diffj = min(diffj, abs(fd - d)/abs(d))

      ! Check for agreement
      if ((abs(fd - d)) <= tol*abs(d)) then
         ! Forward difference quotient and analytic derivatives agree.
         msg(lq, j) = 0

      elseif ((abs(fd - d) <= abs(two*curve*stp)) .or. large) then
         ! Curvature may be the culprit (fudge factor = 2)
         if (large) then
            msg(lq, j) = 4
         else
            msg(lq, j) = 5
         end if
      end if

   end subroutine djckf