dodper Subroutine

   impure subroutine dodper &
      (info, lunerr, &
      n, m, np, nq, &
      ldscld, ldstpd, ldwe, ld2we, ldwd, ld2wd, &
      lwkmn, liwkmn, &
      fjacb, fjacd, &
      diff, msgb, isodr, msgd, &
      xplusd, nrow, neta, ntol)
   !! Controlling routine for printing error reports.
   ! Routines Called  DODPE1, DODPE2, DODPE3, DODPHD
   ! Date Written   860529   (YYMMDD)
   ! Revision Date  920619   (YYMMDD)

      integer, intent(inout) :: info
         !! The variable designating why the computations were stopped.
      integer, intent(in) :: lunerr
         !! The logical unit number used for error messages.
      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.
      integer, intent(in) :: ldscld
         !! The leading dimension of array `scld`.
      integer, intent(in) :: ldstpd
         !! The leading dimension of array `stpd`.
      integer, intent(in) :: ldwe
         !! The leading dimension of array `we`.
      integer, intent(in) :: ld2we
         !! The second dimension of array `we`.
      integer, intent(in) :: ldwd
         !! The leading dimension of array `wd`.
      integer, intent(in) :: ld2wd
         !! The second dimension of array `wd`.
      integer, intent(in) :: lwkmn
         !! The minimum acceptable length of array `work`.
      integer, intent(in) :: liwkmn
         !! The minimum acceptable length of array `iwork`.
      real(wp), intent(in) :: fjacb(n, np, nq)
         !! The Jacobian with respect to `beta`.
      real(wp), intent(in) :: fjacd(n, m, nq)
         !! The Jacobian with respect to `delta`.
      real(wp), intent(in) :: diff(nq, np + m)
         !! The relative differences between the user-supplied and finite difference 
         !! derivatives for each derivative checked.
      integer, intent(in) :: msgb(nq*np + 1)
         !! The error checking results for the Jacobian with respect to `beta`.
      logical, intent(in) :: isodr
         !! The variable designating whether the solution is by ODR (`isodr = .true.`) or
         !! by OLS (`isodr = .false.`).
      integer, intent(in) :: msgd(nq*m + 1)
         !! The error checking results for the Jacobian with respect to `delta`.
      real(wp), intent(in) :: xplusd(n, m)
         !! The values `x + delta`.
      integer, intent(in) :: nrow
         !! The row number of the explanatory variable array at which the derivative is to be
         !! checked.
      integer, intent(in) :: neta
         !! The number of reliable digits in the model.
      integer, intent(in) :: ntol
         !! The number of digits of agreement required between the finite difference and the
         !! user-supplied derivatives.

      ! Local scalars
      integer :: d1, d2, d3, d4, d5
      logical :: head

      ! Variable Definitions (alphabetically)
      !  D1:      The 1st digit (from the left) of INFO.
      !  D2:      The 2nd digit (from the left) of INFO.
      !  D3:      The 3rd digit (from the left) of INFO.
      !  D4:      The 4th digit (from the left) of INFO.
      !  D5:      The 5th digit (from the left) of INFO.
      !  DIFF:    The relative differences between the user supplied and finite difference
      !           derivatives for each derivative checked.
      !  FJACB:   The Jacobian with respect to BETA.
      !  FJACD:   The Jacobian with respect to DELTA.
      !  HEAD:    The variable designating whether the heading is to be printed (HEAD=.TRUE.)
      !           or not (HEAD=.FALSE.).
      !  INFO:    The variable designating why the computations were stopped.
      !  ISODR:   The variable designating whether the solution is by ODR (ISODR=.TRUE.) or
      !           by OLS (ISODR=.FALSE.).
      !  LDSCLD:  The leading dimension of array SCLD.
      !  LDSTPD:  The leading dimension of array STPD.
      !  LDWD:    The leading dimension of array WD.
      !  LDWE:    The leading dimension of array WE.
      !  LD2WD:   The second dimension of array WD.
      !  LD2WE:   The second dimension of array WE.
      !  LIWKMN:  The minimum acceptable length of array IWORK.
      !  LUNERR:  The logical unit number used for error messages.
      !  LWKMN:   The minimum acceptable length of array WORK.
      !  M:       The number of columns of data in the explanatory variable.
      !  MSGB:    The error checking results for the Jacobian wrt BETA.
      !  MSGD:    The error checking results for the Jacobian wrt DELTA.
      !  N:       The number of observations.
      !  NETA:    The number of reliable digits in the model.
      !  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.
      !  NTOL:    The number of digits of agreement required between the finite difference and
      !           the user supplied derivatives.
      !  XPLUSD:  The values X + DELTA.

      ! Print heading
      head = .true.
      call dodphd(head, lunerr)

      ! Extract individual digits from variable INFO
      d1 = mod(info, 100000)/10000
      d2 = mod(info, 10000)/1000
      d3 = mod(info, 1000)/100
      d4 = mod(info, 100)/10
      d5 = mod(info, 10)

      ! Print appropriate error messages for ODRPACK invoked stop
      if ((d1 >= 1 .and. d1 <= 3) .or. (d1 == 7 .or. d1 == 9)) then

         ! Print appropriate messages for errors in
         !         problem specification parameters
         !         dimension specification parameters
         !         number of good digits in X
         !         weights
         call dodpe1(lunerr, info, d1, d2, d3, d4, d5, &
                     n, m, nq, &
                     ldscld, ldstpd, ldwe, ld2we, ldwd, ld2wd, &
                     lwkmn, liwkmn)

      elseif ((d1 == 4) .or. (msgb(1) >= 0)) then

         ! Print appropriate messages for derivative checking
         call dodpe2(lunerr, &
                     n, m, np, nq, &
                     fjacb, fjacd, &
                     diff, msgb(1), msgb(2), isodr, msgd(1), msgd(2), &
                     xplusd, nrow, neta, ntol)

      elseif (d1 == 5) then

         ! Print appropriate error message for user invoked stop from FCN
         call dodpe3(lunerr, d2, d3)

      end if

      ! Print correct form of call statement
      if ((d1 >= 1 .and. d1 <= 3) .or. &
         (d1 == 4 .and. (d2 == 2 .or. d3 == 2)) .or. &
         (d1 == 5)) then
         write (lunerr, 1100)
      end if

      ! Format statements

   1100 format &
         (//' The correct form of the call statement is '// &
         '       call odr'/ &
         '      +     (fcn,'/ &
         '      +     n, m, np, nq,'/ &
         '      +     beta,'/ &
         '      +     y, x,'/ &
         '      +     delta*,'/ &
         '      +     we*, wd*,'/ &
         '      +     ifixb*, ifixx*,'/ &
         '      +     job*, ndigit*, taufac*,'/ &
         '      +     sstol*, partol*, maxit*,'/ &
         '      +     iprint*, lunerr*, lunrpt*,'/ &
         '      +     stpb*, stpd*,'/ &
         '      +     sclb*, scld*,'/ &
         '      +     work*, iwork*,'/ &
         '      +     info*,'/ &
         '      +     lower*, upper*)'/ &
         ' * optional argument')
   
   end subroutine dodper