dodpe2 – odrpack

public impure subroutine dodpe2(lunerr, n, m, np, nq, fjacb, fjacd, diff, msgb1, msgb, isodr, msgd1, msgd, xplusd, nrow, neta, ntol)

Generate the derivative checking report.

Arguments

Type	Intent		Name
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.
real(kind=wp),	intent(in)	::	fjacb(n,np,nq)	The Jacobian with respect to `beta`.
real(kind=wp),	intent(in)	::	fjacd(n,m,nq)	The Jacobian with respect to `delta`.
real(kind=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)	::	msgb1	The error checking results for the Jacobian with respect to `beta`.
integer,	intent(in)	::	msgb(nq,np)	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)	::	msgd1	The error checking results for the Jacobian with respect to `delta`.
integer,	intent(in)	::	msgd(nq,m)	The error checking results for the Jacobian with respect to `delta`.
real(kind=wp),	intent(in)	::	xplusd(n,m)	The values of `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.

Called by

Help

Variables

Type	Visibility		Name
integer,	public	::	i
integer,	public	::	j
integer,	public	::	k
integer,	public	::	l
character(len=1),	public	::	flag
character(len=3),	public	::	typ
logical,	public	::	ftnote(0:9)

Source Code

   impure subroutine dodpe2 &
      (lunerr, &
      n, m, np, nq, &
      fjacb, fjacd, &
      diff, msgb1, msgb, isodr, msgd1, msgd, &
      xplusd, nrow, neta, ntol)
   !! Generate the derivative checking report.
   ! Routines Called  (NONE)
   ! Date Written   860529   (YYMMDD)
   ! Revision Date  920619   (YYMMDD)

      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.
      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) :: msgb1
         !! The error checking results for the Jacobian with respect to `beta`.
      integer, intent(in) :: msgb(nq, np)
         !! 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) :: msgd1
         !! The error checking results for the Jacobian with respect to `delta`.
      integer, intent(in) :: msgd(nq, m)
         !! The error checking results for the Jacobian with respect to `delta`.
      real(wp), intent(in) :: xplusd(n, m)
         !! The values of `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 :: i, j, k, l
      character(len=1) :: flag
      character(len=3) :: typ

      ! Local arrays
      logical :: ftnote(0:9)

      ! Variable Definitions (alphabetically)
      !  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.
      !  FLAG:    The character string indicating highly questionable results.
      !  FTNOTE:  The array controling footnotes.
      !  I:       An index variable.
      !  ISODR:   The variable designating whether the solution is by ODR (ISODR=.TRUE.) or
      !           by OLS (ISODR=.FALSE.).
      !  J:       An index variable.
      !  K:       An index variable.
      !  L:       An index variable.
      !  LUNERR:  The logical unit number used for error messages.
      !  M:       The number of columns of data in the explanatory variable.
      !  MSGB:    The error checking results for the Jacobian wrt BETA.
      !  MSGB1:   The error checking results for the Jacobian wrt BETA.
      !  MSGD:    The error checking results for the Jacobian wrt DELTA.
      !  MSGD1:   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.
      !  TYP:     The character string indicating solution type, ODR or OLS.
      !  XPLUSD:  The values of X + DELTA.

      ! Set up for footnotes

      ftnote = .false.

      do l = 1, nq
         if (msgb1 >= 1) then
            do i = 1, np
               if (msgb(l, i) >= 1) then
                  ftnote(0) = .true.
                  ftnote(msgb(l, i)) = .true.
               end if
            end do
         end if

         if (msgd1 >= 1) then
            do i = 1, m
               if (msgd(l, i) >= 1) then
                  ftnote(0) = .true.
                  ftnote(msgd(l, i)) = .true.
               end if
            end do
         end if
      end do

      ! Print report

      if (isodr) then
         typ = 'ODR'
      else
         typ = 'OLS'
      end if
      write (lunerr, 1000) typ

      do l = 1, nq

         write (lunerr, 2100) l, nrow
         write (lunerr, 2200)

         do i = 1, np
            k = msgb(l, i)
            if (k == 7) then
               flag = '*'
            else
               flag = ' '
            end if
            if (k <= -1) then
               write (lunerr, 3100) i
            elseif (k == 0) then
               write (lunerr, 3200) i, fjacb(nrow, i, l), diff(l, i), flag
            elseif (k == 8) then
               write (lunerr, 3400) i, fjacb(nrow, i, l), flag, k
            elseif (k == 9) then
               write (lunerr, 3500) i, flag, k
            elseif (k >= 1) then
               write (lunerr, 3300) i, fjacb(nrow, i, l), diff(l, i), flag, &
                  k
            end if
         end do
         if (isodr) then
            do i = 1, m
               k = msgd(l, i)
               if (k == 7) then
                  flag = '*'
               else
                  flag = ' '
               end if
               if (k <= -1) then
                  write (lunerr, 4100) nrow, i
               elseif (k == 0) then
                  write (lunerr, 4200) nrow, i, fjacd(nrow, i, l), diff(l, np + i), flag
               elseif (k >= 1) then
                  write (lunerr, 4300) nrow, i, fjacd(nrow, i, l), diff(l, np + i), flag, k
               end if
            end do
         end if
      end do

      ! Print footnotes

      if (ftnote(0)) then

         write (lunerr, 5000)
         if (ftnote(1)) write (lunerr, 5100)
         if (ftnote(2)) write (lunerr, 5200)
         if (ftnote(3)) write (lunerr, 5300)
         if (ftnote(4)) write (lunerr, 5400)
         if (ftnote(5)) write (lunerr, 5500)
         if (ftnote(6)) write (lunerr, 5600)
         if (ftnote(7)) write (lunerr, 5700)
         if (ftnote(8)) write (lunerr, 5800)
         if (ftnote(9)) write (lunerr, 5900)
      end if

      if (neta < 0) then
         write (lunerr, 6000) - neta
      else
         write (lunerr, 6100) neta
      end if
      write (lunerr, 7000) ntol

      ! Print out row of explanatory variable which was checked.

      write (lunerr, 8100) nrow

      do j = 1, m
         write (lunerr, 8110) nrow, j, xplusd(nrow, j)
      end do

      ! Format statements

   1000 format &
         (//' *** Derivative checking report for fit by method of ', A3, &
         ' ***'/)
   2100 format(/'     For response ', I2, ' of observation ', I5/)
   2200 format('                      ', '         User', &
            '               ', '                '/ &
            '                      ', '     Supplied', &
            '     Relative', '    Derivative '/ &
            '        Derivative WRT', '        Value', &
            '   Difference', '    Assessment '/)
   3100 format('             BETA(', I3, ')', '       ---   ', &
            '       ---   ', '    Unchecked')
   3200 format('             BETA(', I3, ')', 1P, 2E13.2, 3X, A1, &
            'Verified')
   3300 format('             BETA(', I3, ')', 1P, 2E13.2, 3X, A1, &
            'Questionable (see note ', I1, ')')
   3400 format('             BETA(', I3, ')', 1P, 1E13.2, 13X, 3X, A1, &
            'Questionable (see note ', I1, ')')
   3500 format('             BETA(', I3, ')', 1P, 13X, 13X, 3X, A1, &
            'Small bounds (see note ', I1, ')')
   4100 format('          DELTA(', I2, ',', I2, ')', '       ---   ', &
            '       ---   ', '    Unchecked')
   4200 format('          DELTA(', I2, ',', I2, ')', 1P, 2E13.2, 3X, A1, &
            'Verified')
   4300 format('          DELTA(', I2, ',', I2, ')', 1P, 2E13.2, 3X, A1, &
            'Questionable (see note ', I1, ')')
   5000 format &
         (/'     NOTES:')
   5100 format &
         (/'      (1) User supplied and finite difference derivatives', &
         ' agree, but'/ &
         '          results are questionable because both are zero.')
   5200 format &
         (/'      (2) User supplied and finite difference derivatives', &
         ' agree, but'/ &
         '          results are questionable because one is', &
         ' identically zero'/ &
         '          and the other is only approximately zero.')
   5300 format &
         (/'      (3) User supplied and finite difference derivatives', &
         ' disagree, but'/ &
         '          results are questionable because one is', &
         ' identically zero'/ &
         '          and the other is not.')
   5400 format &
         (/'      (4) User supplied and finite difference derivatives', &
         ' disagree, but'/ &
         '          finite difference derivative is questionable', &
         ' because either'/ &
         '          the ratio of relative curvature to relative', &
         ' slope is too high'/ &
         '          or the scale is wrong.')
   5500 format &
         (/'      (5) User supplied and finite difference derivatives', &
         ' disagree, but'/ &
         '          finite difference derivative is questionable', &
         ' because the'/ &
         '          ratio of relative curvature to relative slope is', &
         ' too high.')
   5600 format &
         (/'      (6) User supplied and finite difference derivatives', &
         ' disagree, but'/ &
         '          have at least 2 digits in common.')
   5700 format &
         (/'      (7) User supplied and finite difference derivatives', &
         ' disagree, and'/ &
         '          have fewer than 2 digits in common.  derivative', &
         ' checking must'/ &
         '          be turned off in order to proceed.')
   5800 format &
         (/'      (8) User supplied and finite difference derivatives', &
         ' disagree, and'/ &
         '          bound constraints are too small to calculate', &
         ' further'/ &
         '          information.')
   5900 format &
         (/'      (9) Bound constraints too small to check derivative.')
   6000 format &
         (/'     Number of reliable digits in function results       ', &
         I5/ &
         '        (estimated by ODRPACK)')
   6100 format &
         (/'     Number of reliable digits in function results       ', &
         I5/ &
         '        (supplied by user)')
   7000 format &
         (/'     Number of digits of agreement required between      '/ &
         '     user supplied and finite difference derivative for  '/ &
         '     user supplied derivative to be considered verified  ', &
         I5)
   8100 format &
         (/'     Row number at which derivatives were checked        ', &
         I5// &
         '       -values of the explanatory variables at this row'/)
   8110 format &
         (10X, 'X(', I2, ',', I2, ')', 1X, 1P, 3E16.8)

   end subroutine dodpe2

dodpe2 Subroutine

Contents

Variables

Source Code

public impure subroutine dodpe2(lunerr, n, m, np, nq, fjacb, fjacd, diff, msgb1, msgb, isodr, msgd1, msgd, xplusd, nrow, neta, ntol)

Arguments

Called by

Variables

Source Code