Generate the derivative checking report.
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| integer, | intent(in) | :: | lunerr |
Logical unit number used for error messages. |
||
| integer, | intent(in) | :: | n |
Number of observations. |
||
| integer, | intent(in) | :: | m |
Number of columns of data in the explanatory variable. |
||
| integer, | intent(in) | :: | np |
Number of function parameters. |
||
| integer, | intent(in) | :: | q |
Number of responses per observation. |
||
| real(kind=wp), | intent(in) | :: | fjacb(n,np,q) |
Jacobian with respect to |
||
| real(kind=wp), | intent(in) | :: | fjacd(n,m,q) |
Jacobian with respect to |
||
| real(kind=wp), | intent(in) | :: | diff(q,np+m) |
Relative differences between the user-supplied and finite difference derivatives for each derivative checked. |
||
| integer, | intent(in) | :: | msgb1 |
Error checking results for the Jacobian with respect to |
||
| integer, | intent(in) | :: | msgb(q,np) |
Error checking results for the Jacobian with respect to |
||
| logical, | intent(in) | :: | isodr |
Variable designating whether the solution is by ODR ( |
||
| integer, | intent(in) | :: | msgd1 |
Error checking results for the Jacobian with respect to |
||
| integer, | intent(in) | :: | msgd(q,m) |
Error checking results for the Jacobian with respect to |
||
| real(kind=wp), | intent(in) | :: | xplusd(n,m) |
Values of |
||
| integer, | intent(in) | :: | nrow |
Row number of the explanatory variable array at which the derivative is to be checked. |
||
| integer, | intent(in) | :: | neta |
Number of reliable digits in the model. |
||
| integer, | intent(in) | :: | ntol |
Number of digits of agreement required between the finite difference and the user-supplied derivatives. |
| Type | Visibility | Attributes | Name | Initial | |||
|---|---|---|---|---|---|---|---|
| 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) |
impure subroutine print_error_derivative & (lunerr, & n, m, np, q, & fjacb, fjacd, & diff, msgb1, msgb, isodr, msgd1, msgd, & xplusd, nrow, neta, ntol) !! Generate the derivative checking report. integer, intent(in) :: lunerr !! Logical unit number used for error messages. integer, intent(in) :: n !! Number of observations. integer, intent(in) :: m !! Number of columns of data in the explanatory variable. integer, intent(in) :: np !! Number of function parameters. integer, intent(in) :: q !! Number of responses per observation. real(wp), intent(in) :: fjacb(n, np, q) !! Jacobian with respect to `beta`. real(wp), intent(in) :: fjacd(n, m, q) !! Jacobian with respect to `delta`. real(wp), intent(in) :: diff(q, np + m) !! Relative differences between the user-supplied and finite difference derivatives !! for each derivative checked. integer, intent(in) :: msgb1 !! Error checking results for the Jacobian with respect to `beta`. integer, intent(in) :: msgb(q, np) !! Error checking results for the Jacobian with respect to `beta`. logical, intent(in) :: isodr !! Variable designating whether the solution is by ODR (`isodr = .true.`) or by !! OLS (`isodr = .false.`). integer, intent(in) :: msgd1 !! Error checking results for the Jacobian with respect to `delta`. integer, intent(in) :: msgd(q, m) !! Error checking results for the Jacobian with respect to `delta`. real(wp), intent(in) :: xplusd(n, m) !! Values of `x` + `delta`. integer, intent(in) :: nrow !! Row number of the explanatory variable array at which the derivative is to be !! checked. integer, intent(in) :: neta !! Number of reliable digits in the model. integer, intent(in) :: ntol !! 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) ! FLAG: The character string indicating highly questionable results. ! FTNOTE: The array controling footnotes. ! I: An index variable. ! J: An index variable. ! K: An index variable. ! L: An index variable. ! TYP: The character string indicating solution type, ODR or OLS. ! Set up for footnotes ftnote = .false. do l = 1, q 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, q 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 print_error_derivative