print_report_initial Subroutine

   impure subroutine print_report_initial &
      (ipr, lunrpt, &
       anajac, cdjac, chkjac, initd, restart, isodr, implicit, dovcv, redoj, &
       msgb1, msgb, msgd1, msgd, &
       n, m, np, q, npp, nnzw, &
       x, ifixx, ldifx, delta, wd, ldwd, ld2wd, tt, ldtt, stpd, ldstpd, &
       y, we, ldwe, ld2we, penalty, beta, ifixb, ssf, stpb, lower, &
       upper, job, neta, taufac, sstol, partol, maxit, wss, wssdel, wsseps)
   !! Generate initial summary report.

      use odrpack_kinds, only: zero
      use odrpack_core, only: hstep

      integer, intent(in) :: ipr
         !! Value indicating the report to be printed.
      integer, intent(in) :: lunrpt
         !! Logical unit number for the computation reports.
      logical, intent(in) :: anajac
         !! Variable designating whether the Jacobians are computed by finite differences
         !! (`.false.`) or not (`.true.`).
      logical, intent(in) :: cdjac
         !! Variable designating whether the Jacobians are computed by central differences
         !! (`.true.`) or forward differences (`.false.`).
      logical, intent(in) :: chkjac
         !! Variable designating whether the user-supplied Jacobians are to be checked
         !! (`.true.`) or not (`.false.`).
      logical, intent(in) :: initd
         !! Variable designating whether `delta` is initialized to zero (`.true.`)
         !! or to the values in the first `n` by `m` elements of array `rwork` (`.false.`).
      logical, intent(in) :: restart
         !! Variable designating whether the call is a restart (`.true.`) or not (`.false.`).
      logical, intent(in) :: isodr
         !! Variable designating whether the solution is by ODR (`.true.`) or by OLS (`.false.`).
      logical, intent(in) :: implicit
         !! Variable designating whether the solution is by implicit ODR (`.true.`)
         !! or explicit ODR (`.false.`).
      logical, intent(in) :: dovcv
         !! Variable designating whether the covariance matrix is to be computed (`.true.`)
         !! or not (`.false.`).
      logical, intent(in) :: redoj
         !! Variable designating whether the Jacobian matrix is to be recomputed for the
         !! computation of the covariance matrix (`.true.`) or not (`.false.`).
      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`.
      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`.
      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.
      integer, intent(in) :: npp
         !! Number of function parameters being estimated.
      integer, intent(in) :: nnzw
         !! Number of nonzero observational error weights.
      real(wp), intent(in) :: x(n, m)
         !! Explanatory variable.
      integer, intent(in) :: ifixx(ldifx, m)
         !! Values designating whether the elements of `x` are fixed at their input values or not.
      integer, intent(in) :: ldifx
         !! Leading dimension of array `ifixx`.
      real(wp), intent(in) :: delta(n, m)
         !! Estimated errors in the explanatory variables.
      real(wp), intent(in) :: wd(ldwd, ld2wd, m)
         !! `delta` weights.
      integer, intent(in) :: ldwd
         !! Leading dimension of array `wd`.
      integer, intent(in) :: ld2wd
         !! Second dimension of array `wd`.
      real(wp), intent(in) :: tt(ldtt, m)
         !! Scaling values for `delta`.
      integer, intent(in) :: ldtt
         !! Leading dimension of array `tt`.
      real(wp), intent(in) :: stpd(ldstpd, m)
         !! Relative step used for computing finite difference derivatives with respect to `delta`.
      integer, intent(in) :: ldstpd
         !! Leading dimension of array `stpd`.
      real(wp), intent(in) :: y(n, q)
         !! Response variable. Unused when the model is implicit.
      real(wp), intent(in) :: we(ldwe, ld2we, q)
         !! `epsilon` weights.
      integer, intent(in) :: ldwe
         !! Leading dimension of array `we`.
      integer, intent(in) :: ld2we
         !! Second dimension of array `we`.
      real(wp), intent(in) :: penalty
         !! Penalty parameter for an implicit model.
      real(wp), intent(in) :: beta(np)
         !! Function parameters.
      integer, intent(in) :: ifixb(np)
         !! Values designating whether the elements of `beta` are fixed at their input values
         !! or not.
      real(wp), intent(in) :: ssf(np)
         !! Scaling values for `beta`.
      real(wp), intent(in) :: stpb(np)
         !! Relative step used for computing finite difference derivatives with respect to `beta`.
      real(wp), intent(in) :: lower(np)
         !! Lower bounds for `beta`.
      real(wp), intent(in) :: upper(np)
         !! Upper bounds for `beta`.
      integer, intent(in) :: job
         !! Variable controlling problem initialization and computational method.
      integer, intent(in) :: neta
         !! Number of accurate digits in the function results. A negative value indicates
         !! that `neta` was estimated by 'odrpack'. A positive value indicates the value was
         !! supplied by the user.
      real(wp), intent(in) :: taufac
         !! Factor used to compute the initial trust region diameter.
      real(wp), intent(in) :: sstol
         !! Sum-of-squares convergence stopping tolerance.
      real(wp), intent(in) :: partol
         !! Parameter convergence stopping tolerance.
      integer, intent(in) :: maxit
         !! Maximum number of iterations allowed.
      real(wp), intent(in) :: wss
         !! Sum-of-squares of the weighted `epsilon`s and `delta`s.
      real(wp), intent(in) :: wssdel
         !! Sum-of-squares of the weighted `delta`s.
      real(wp), intent(in) :: wsseps
         !! Sum-of-squares of the weighted `epsilon`s.

      ! Local scalars
      real(wp) :: temp1, temp2, temp3
      integer :: i, itemp, j, job1, job2, job3, job4, job5, l

      ! Local arrays
      character(len=2) :: tempc0
      character(len=5) :: tempc1
      character(len=13) :: tempc2

      ! Variable Definitions (alphabetically)
      !  I:       An indexing variable.
      !  ITEMP:   A temporary integer value.
      !  J:       An indexing variable.
      !  JOB1:    The 1st digit (from the left) of variable JOB.
      !  JOB2:    The 2nd digit (from the left) of variable JOB.
      !  JOB3:    The 3rd digit (from the left) of variable JOB.
      !  JOB4:    The 4th digit (from the left) of variable JOB.
      !  JOB5:    The 5th digit (from the left) of variable JOB.
      !  L:       An indexing variable.
      !  TEMPC0:  A temporary CHARACTER*2 value.
      !  TEMPC1:  A temporary CHARACTER*5 value.
      !  TEMPC2:  A temporary CHARACTER*13 value.
      !  TEMP1:   A temporary REAL (wp) value.
      !  TEMP2:   A temporary REAL (wp) value.
      !  TEMP3:   A temporary REAL (wp) value.

      ! Print problem size specification
      write (lunrpt, 1000) n, nnzw, q, m, np, npp

      ! Print control values
      job1 = job/10000
      job2 = mod(job, 10000)/1000
      job3 = mod(job, 1000)/100
      job4 = mod(job, 100)/10
      job5 = mod(job, 10)
      write (lunrpt, 1100) job
      if (restart) then
         write (lunrpt, 1110) job1
      else
         write (lunrpt, 1111) job1
      end if
      if (isodr) then
         if (initd) then
            write (lunrpt, 1120) job2
         else
            write (lunrpt, 1121) job2
         end if
      else
         write (lunrpt, 1122) job2, job5
      end if
      if (dovcv) then
         write (lunrpt, 1130) job3
         if (redoj) then
            write (lunrpt, 1131)
         else
            write (lunrpt, 1132)
         end if
      else
         write (lunrpt, 1133) job3
      end if
      if (anajac) then
         write (lunrpt, 1140) job4
         if (chkjac) then
            if (msgb1 >= 1 .or. msgd1 >= 1) then
               write (lunrpt, 1141)
            else
               write (lunrpt, 1142)
            end if
         else
            write (lunrpt, 1143)
         end if
      elseif (cdjac) then
         write (lunrpt, 1144) job4
      else
         write (lunrpt, 1145) job4
      end if
      if (isodr) then
         if (implicit) then
            write (lunrpt, 1150) job5
         else
            write (lunrpt, 1151) job5
         end if
      else
         write (lunrpt, 1152) job5
      end if
      if (neta < 0) then
         write (lunrpt, 1200) - neta
      else
         write (lunrpt, 1210) neta
      end if
      write (lunrpt, 1300) taufac

      ! Print stopping criteria
      write (lunrpt, 1400) sstol, partol, maxit

      ! Print initial sum of squares
      if (implicit) then
         write (lunrpt, 1500) wssdel
         if (isodr) then
            write (lunrpt, 1510) wss, wsseps, penalty
         end if
      else
         write (lunrpt, 1600) wss
         if (isodr) then
            write (lunrpt, 1610) wssdel, wsseps
         end if
      end if

      if (ipr >= 2) then

         ! Print function parameter data
         write (lunrpt, 4000)
         if (chkjac .and. &
             ((msgb1 >= 1) .or. &
              (msgd1 >= 1))) then
            write (lunrpt, 4110)
         elseif (anajac) then
            write (lunrpt, 4120)
         else
            write (lunrpt, 4200)
         end if
         do j = 1, np
            if (ifixb(1) < 0) then
               tempc1 = '   NO'
            else
               if (ifixb(j) /= 0) then
                  tempc1 = '   NO'
               else
                  tempc1 = '  YES'
               end if
            end if
            if (anajac) then
               if (chkjac .and. &
                   ((msgb1 >= 1) .or. &
                    (msgd1 >= 1))) then
                  itemp = -1
                  do l = 1, q
                     itemp = max(itemp, msgb(l, j))
                  end do
                  if (itemp <= -1) then
                     tempc2 = '    UNCHECKED'
                  elseif (itemp == 0) then
                     tempc2 = '     VERIFIED'
                  elseif (itemp >= 1) then
                     tempc2 = ' QUESTIONABLE'
                  end if
               else
                  tempc2 = '             '
               end if
            else
               tempc2 = '             '
            end if
            if (ssf(1) < zero) then
               temp1 = abs(ssf(1))
            else
               temp1 = ssf(j)
            end if
            if (anajac) then
               write (lunrpt, 4310) j, beta(j), tempc1, temp1, lower(j), &
                  upper(j), tempc2
            else
               if (cdjac) then
                  temp2 = hstep(1, neta, 1, j, stpb, 1)
               else
                  temp2 = hstep(0, neta, 1, j, stpb, 1)
               end if
               write (lunrpt, 4320) j, beta(j), tempc1, temp1, &
                  lower(j), upper(j), temp2
            end if
         end do

         ! Print explanatory variable data
         if (isodr) then
            write (lunrpt, 2010)
            if (chkjac .and. &
                ((msgb1 >= 1) .or. &
                 (msgd1 >= 1))) then
               write (lunrpt, 2110)
            elseif (anajac) then
               write (lunrpt, 2120)
            else
               write (lunrpt, 2130)
            end if
         else
            write (lunrpt, 2020)
            write (lunrpt, 2140)
         end if
         if (isodr) then
            do j = 1, m
               tempc0 = '1,'
               do i = 1, n, n - 1

                  if (ifixx(1, 1) < 0) then
                     tempc1 = '   NO'
                  else
                     if (ldifx == 1) then
                        if (ifixx(1, j) == 0) then
                           tempc1 = '  YES'
                        else
                           tempc1 = '   NO'
                        end if
                     else
                        if (ifixx(i, j) == 0) then
                           tempc1 = '  YES'
                        else
                           tempc1 = '   NO'
                        end if
                     end if
                  end if

                  if (tt(1, 1) < zero) then
                     temp1 = abs(tt(1, 1))
                  else
                     if (ldtt == 1) then
                        temp1 = tt(1, j)
                     else
                        temp1 = tt(i, j)
                     end if
                  end if

                  if (wd(1, 1, 1) < zero) then
                     temp2 = abs(wd(1, 1, 1))
                  else
                     if (ldwd == 1) then
                        if (ld2wd == 1) then
                           temp2 = wd(1, 1, j)
                        else
                           temp2 = wd(1, j, j)
                        end if
                     else
                        if (ld2wd == 1) then
                           temp2 = wd(i, 1, j)
                        else
                           temp2 = wd(i, j, j)
                        end if
                     end if
                  end if

                  if (anajac) then
                     if (chkjac .and. &
                         (((msgb1 >= 1) .or. &
                           (msgd1 >= 1)) .and. &
                          (i == 1))) then
                        itemp = -1
                        do l = 1, q
                           itemp = max(itemp, msgd(l, j))
                        end do
                        if (itemp <= -1) then
                           tempc2 = '    UNCHECKED'
                        elseif (itemp == 0) then
                           tempc2 = '     VERIFIED'
                        elseif (itemp >= 1) then
                           tempc2 = ' QUESTIONABLE'
                        end if
                     else
                        tempc2 = '             '
                     end if
                     if (m <= 9) then
                        write (lunrpt, 5110) &
                           tempc0, j, x(i, j), &
                           delta(i, j), tempc1, temp1, temp2, tempc2
                     else
                        write (lunrpt, 5120) &
                           tempc0, j, x(i, j), &
                           delta(i, j), tempc1, temp1, temp2, tempc2
                     end if
                  else
                     tempc2 = '             '
                     if (cdjac) then
                        temp3 = hstep(1, neta, i, j, stpd, ldstpd)
                     else
                        temp3 = hstep(0, neta, i, j, stpd, ldstpd)
                     end if
                     if (m <= 9) then
                        write (lunrpt, 5210) &
                           tempc0, j, x(i, j), &
                           delta(i, j), tempc1, temp1, temp2, temp3
                     else
                        write (lunrpt, 5220) &
                           tempc0, j, x(i, j), &
                           delta(i, j), tempc1, temp1, temp2, temp3
                     end if
                  end if

                  tempc0 = 'N,'

               end do
               if (j < m) write (lunrpt, 6000)
            end do
         else

            do j = 1, m
               tempc0 = '1,'
               do i = 1, n, n - 1
                  if (m <= 9) then
                     write (lunrpt, 5110) &
                        tempc0, j, x(i, j)
                  else
                     write (lunrpt, 5120) &
                        tempc0, j, x(i, j)
                  end if
                  tempc0 = 'N,'
               end do
               if (j < m) write (lunrpt, 6000)
            end do
         end if

         ! Print response variable data and observation error weights
         if (.not. implicit) then
            write (lunrpt, 3000)
            write (lunrpt, 3100)
            do l = 1, q
               tempc0 = '1,'
               do i = 1, n, n - 1
                  if (we(1, 1, 1) < zero) then
                     temp1 = abs(we(1, 1, 1))
                  elseif (ldwe == 1) then
                     if (ld2we == 1) then
                        temp1 = we(1, 1, l)
                     else
                        temp1 = we(1, l, l)
                     end if
                  else
                     if (ld2we == 1) then
                        temp1 = we(i, 1, l)
                     else
                        temp1 = we(i, l, l)
                     end if
                  end if
                  if (q <= 9) then
                     write (lunrpt, 5110) &
                        tempc0, l, y(i, l), temp1
                  else
                     write (lunrpt, 5120) &
                        tempc0, l, y(i, l), temp1
                  end if
                  tempc0 = 'N,'
               end do
               if (l < q) write (lunrpt, 6000)
            end do
         end if
      end if

      ! Format statements

1000  format &
         (/' --- Problem Size:'/ &
           '            N = ', I5, &
           '          (number with nonzero weight = ', I5, ')'/ &
           '            Q = ', I5/ &
           '            M = ', I5/ &
           '           NP = ', I5, &
           '          (number unfixed = ', I5, ')')
1100  format &
         (/' --- Control Values:'/ &
           '          JOB = ', I5.5/ &
           '              = ABCDE, where')
1110  format &
         ('                       A=', I1, ' ==> fit is a restart.')
1111  format &
         ('                       A=', I1, ' ==> fit is not a restart.')
1120  format &
         ('                       B=', I1, ' ==> deltas are initialized', &
          ' to zero.')
1121  format &
         ('                       B=', I1, ' ==> deltas are initialized', &
          ' by user.')
1122  format &
         ('                       B=', I1, ' ==> deltas are fixed at', &
          ' zero since E=', I1, '.')
1130  format &
         ('                       C=', I1, ' ==> covariance matrix will', &
          ' be computed using')
1131  format &
         ('                               derivatives re-', &
          'evaluated at the solution.')
1132  format &
         ('                               derivatives from the', &
          ' last iteration.')
1133  format &
         ('                       C=', I1, ' ==> covariance matrix will', &
          ' not be computed.')
1140  format &
         ('                       D=', I1, ' ==> derivatives are', &
          ' supplied by user.')
1141  format &
         ('                               derivatives were checked.'/ &
          '                               results appear questionable.')
1142  format &
         ('                               derivatives were checked.'/ &
          '                               results appear correct.')
1143  format &
         ('                               derivatives were not', &
          ' checked.')
1144  format &
         ('                       D=', I1, ' ==> derivatives are', &
          ' estimated by central', &
          ' differences.')
1145  format &
         ('                       D=', I1, ' ==> derivatives are', &
          ' estimated by forward', &
          ' differences.')
1150  format &
         ('                       E=', I1, ' ==> method is implicit ODR.')
1151  format &
         ('                       E=', I1, ' ==> method is explicit ODR.')
1152  format &
         ('                       E=', I1, ' ==> method is explicit OLS.')
1200  format &
         ('       NDIGIT = ', I5, '          (estimated by ODRPACK)')
1210  format &
         ('       NDIGIT = ', I5, '          (supplied by user)')
1300  format &
         ('       TAUFAC = ', 1P, E12.2)
1400  format &
         (/' --- Stopping Criteria:'/ &
           '        SSTOL = ', 1P, E12.2, &
           '   (sum of squares stopping tolerance)'/ &
           '       PARTOL = ', 1P, E12.2, &
           '   (parameter stopping tolerance)'/ &
           '        MAXIT = ', I5, &
           '          (maximum number of iterations)')
1500  format &
         (/' --- Initial Sum of Squared Weighted Deltas =', &
           17X, 1P, E17.8)
1510  format &
         ('         Initial Penalty Function Value     =', 1P, E17.8/ &
          '                 Penalty Term               =', 1P, E17.8/ &
          '                 Penalty Parameter          =', 1P, E10.1)
1600  format &
         (/' --- Initial Weighted Sum of Squares        =', 1P, E17.8)
1610  format &
         ('         Sum of Squared Weighted Deltas     =', 1P, E17.8/ &
          '         Sum of Squared Weighted Epsilons   =', 1P, E17.8)
2010  format &
         (/' --- Explanatory Variable and Delta Weight Summary:')
2020  format &
         (/' --- Explanatory Variable Summary:')
2110  format &
         (/'       Index      X(I,J)  DELTA(I,J)    Fixed', &
           '     Scale    Weight    Derivative'/ &
           '                                             ', &
           '                        Assessment'/, &
           '       (I,J)                          (IFIXX)', &
           '    (SCLD)      (WD)              '/)
2120  format &
         (/'       Index      X(I,J)  DELTA(I,J)    Fixed', &
           '     Scale    Weight              '/ &
           '                                             ', &
           '                                  '/, &
           '       (I,J)                          (IFIXX)', &
           '    (SCLD)      (WD)              '/)
2130  format &
         (/'       Index      X(I,J)  DELTA(I,J)    Fixed', &
           '     Scale    Weight    Derivative'/ &
           '                                             ', &
           '                         Step Size'/, &
           '       (I,J)                          (IFIXX)', &
           '    (SCLD)      (WD)        (STPD)'/)
2140  format &
         (/'       Index      X(I,J)'/ &
           '       (I,J)            '/)
3000  format &
         (/' --- Response Variable and Epsilon Error Weight', &
           ' Summary:')
3100  format &
         (/'       Index      Y(I,L)      Weight'/ &
           '       (I,L)                    (WE)'/)
4000  format &
         (/' --- Function Parameter Summary:')
4110  format &
         (/'       Index   BETA(K)    Fixed     Scale   LOWER(K)', &
           '   UPPER(K)    Derivative'/ &
           '                                                    ', &
           '               Assessment'/, &
           '         (K)            (IFIXB)    (SCLB)           ', &
           '                         '/)
4120  format &
         (/'       Index   BETA(K)    Fixed     Scale   LOWER(K)', &
           '   UPPER(K)              '/ &
           '                                                    ', &
           '                         '/, &
           '         (K)            (IFIXB)    (SCLB)           ', &
           '                         '/)
4200  format &
         (/'       Index   BETA(K)    Fixed     Scale   LOWER(K)', &
           '   UPPER(K)    Derivative'/ &
           '                                                    ', &
           '                Step Size'/, &
           '         (K)            (IFIXB)    (SCLB)           ', &
           '                   (STPB)'/)
4310  format &
         (7X, I5, 1P, E10.2, 4X, A5, E10.2, E11.2E3, E11.2E3, 1X, A13)
4320  format &
         (7X, I5, 1P, E10.2, 4X, A5, E10.2, E11.2E3, E11.2E3, 1X, E13.5)
5110  format &
         (9X, A2, I1, 1P, 2E12.3, 4X, A5, 2E10.2, 1X, A13)
5120  format &
         (8X, A2, I2, 1P, 2E12.3, 4X, A5, 2E10.2, 1X, A13)
5210  format &
         (9X, A2, I1, 1P, 2E12.3, 4X, A5, 2E10.2, 1X, E13.5)
5220  format &
         (8X, A2, I2, 1P, 2E12.3, 4X, A5, 2E10.2, 1X, E13.5)
6000  format &
         (' ')
   end subroutine print_report_initial