module Random

!*******************************************************************************
  !
  !This module contains various random number generators.
  !
!*******************************************************************************

    implicit none

    ! Data dictionary: global variables
    integer   :: clim_seed = 0       ! Climate RNG seed
    integer   :: rng_seed            ! Regular RNG seed
    logical   :: reset_clim = .true. ! Reset the climate seed?

    private clim_seed, rng_seed, reset_clim

contains

    !:.........................................................................:

    real function urand(lb, ub, seed)
        !
        !  Returns a uniformly-distributed random number in the range (lb, ub],
        !    default to (0.0, 1.0]
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        real, optional, intent(in) :: lb   ! Upper bound
        real, optional, intent(in) :: ub   ! Lower bound
        real, optional, intent(in) :: seed ! Optional RNG seed

        ! Data dictionary: local variables
        integer :: iseed ! Local seed
        real    :: rnd   ! Random number
        real    :: lower ! Local lower bound
        real    :: upper ! Local upper bound

        ! Set the seed if it is present
        if (present(seed)) then
            iseed = int(seed)
            call set_random_seed(iseed)
        endif

        ! Set the lower bound if present, otherwise default to 0.0
        if (present(lb)) then
            lower = lb
        else
            lower = 0.0
        endif

        ! Set the upper bound if present, otherwise default to 1.0
        if (present(ub)) then
            upper = ub
        else
            upper = 1.0
        endif

        ! Get a random number with intrinsic
        call random_number(rnd)

        ! Rescale to the correct bounds
        urand = lower + (upper - lower)*rnd

    end function urand

    !:.........................................................................:

    real function nrand(mean, std, seed)
        !
        !  Returns a normally-distributed random number with given mean and
        !    standard deviation, default to mean = 0.0, sd = 1.0
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        real, optional, intent(in) :: mean ! Input mean
        real, optional, intent(in) :: std  ! Optional standard deviation
         real, optional, intent(in) :: seed ! Optional input RNG seed

        ! Data dictionary: local variables
        integer :: iseed ! Local seed
        real    :: mn    ! Local mean
        real    :: st    ! Local standard deviation
        real    :: x1    ! Random uniform between (-1.0, 1.0]
        real    :: x2    ! Random uniform between (-1.0, 1.0]
        real    :: w     ! Temporary variable
        real    :: y1    ! Temporary variable to calculate nrand
        real    :: y2    ! Temporary variable to calculate nrand

        ! Set the mean and sd if present, otherwise use defaults
        if (present(mean)) then
            mn = mean
        else
            mn = 0.0
        endif

        if (present(std)) then
            st = std
        else
            st = 1.0
        endif

        ! Box-Muller polar method
        do
            ! Set the seed if present, and generate 2 uniform random numbers
            ! between -1.0 and 1.0
            if (present(seed)) then
                iseed = int(seed)
                x1 = urand(-1.0, 1.0, seed)
                x2 = urand(-1.0, 1.0, seed)
            else
                x1 = urand(-1.0, 1.0)
                x2 = urand(-1.0, 1.0)
            endif

            ! Calculate sum of squared values
            ! Check to make sure not 0.0 or > 1.0
            w = x1**2 + x2**2
            if (w /= 0.0 .and. w < 1.0) exit
        end do

        ! Calculate y1 and y2 from w and x1, x2
        w = sqrt((-2.0*log(w))/w)
        y1 = x1*w
        y2 = x2*w

        ! Pick one, adjust its mean and std
        nrand = y1*st + mn

    end function nrand

    !:.........................................................................:

    real function clim_urand(lb, ub)
        !
        !  Returns a uniformly distributed random number (used for climate
        !    data) between a lower and upper bound (default to 0.0 and 1.0).
        !  Adapted from the Numerical Recipes First Edition
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictonary: constants
        ! Parameters for creating some randomness
        integer, parameter :: M1 = 259200
        integer, parameter :: M2 = 134456
        integer, parameter :: M3 = 243000
        integer, parameter :: IA1 = 7141
        integer, parameter :: IA2 = 8121
        integer, parameter :: IA3 = 4561
        integer, parameter :: IC1 = 54773
        integer, parameter :: IC2 = 28411
        integer, parameter :: IC3 = 51349

        ! Data dictionary: calling arguments
        real, optional, intent(in) :: lb ! Optional lower bound
        real, optional, intent(in) :: ub ! Optional upper bound

        ! Data dictionary: local variables
        real, dimension(97) :: r              ! Array of numbers to pull from
        real                :: lower          ! Local lower bound
        real                :: upper          ! Local upper bound
        real                :: ran1           ! Number from r
        real                :: rm1            ! Temp. variable
        real                :: rm2            ! Temp. variable
        integer             :: ix1            ! Temp. variable
        integer             :: ix2            ! Temp. variable
        integer             :: ix3            ! Temp. variable
        integer             :: j              ! Indexing variable
        logical             :: first = .true. ! First time we have called this?
        save

        ! Set the lower bound if present, otherwise default to 0.0
        if (present(lb)) then
            lower = lb
        else
            lower = 0.0
        endif

        ! Set the upper bound if present, otherwise default to 1.0
        if (present(ub)) then
            upper = ub
        else
            upper = 1.0
        endif

        ! Generate two numbers from division of large integers
        rm1 = 1.0/M1
        rm2 = 1.0/M1

        if (first .or. reset_clim) then

            ! First time we are calling this
            ! Generate some random numbers by doing some integer math
            ix1 = mod(abs(IC1 - clim_seed), M1)
            ix1 = mod(IA1*ix1 + IC1, m1)
            ix2 = mod(ix1, M2)
            ix1 = mod(IA1*ix1 + IC1, M1)
            ix3 = mod(ix1, M3)
            do j = 1, 97
                ix1 = mod(IA1*ix1 + IC1, M1)
                ix2 = mod(IA2*ix2 + IC2, M2)
                r(j) = (real(ix1) + real(ix2)*rm2)*rm1
            enddo
            first = .false.
            reset_clim = .false.
        endif

        ! Do some more math - we will keep doing just this on future calls
        ix1 = mod(IA1*ix1 + IC1, M1)
        ix2 = mod(IA2*ix2 + IC2, M2)
        ix3 = mod(IA3*ix3 + IC3, M3)

        ! Check to make sure j is in the correct range
        j = 1 + (97*ix3)/M3
        if (j .gt. 97 .or. j .lt. 1) then
            j = 97
            write(*, *) 'Error in climate RNG'
        else
            ran1 = r(j)
            r(j) = (real(ix1) + real(ix2)*rm2)*rm1
        endif

        ! Rescale to correct bounds
        clim_urand = lower + (upper - lower)*ran1

    end function clim_urand

    !:.........................................................................:

    real function clim_nrand(mean, std)
        !
        !  Returns a normally distributed random number (used for climate
        !    data) with a given mean and standard deviation
        !    (default to mean = 0.0 and sd = 1.0)
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        real, optional :: mean ! Input mean
        real, optional :: std  ! Input standard deviation

        ! Data dictionary: local variables
        real :: mn ! Local mean
        real :: st ! Local standard deviation
        real :: x1 ! Random uniform between (-1.0, 1.0]
        real :: x2 ! Random uniform between (-1.0, 1.0]
        real :: w  ! Temporary variable
        real :: y1 ! Temporary variable to calculate nrand
        real :: y2 ! Temporary variable to calculate nrand

        ! Set mean and sd if present, otherwise use defaults
        if (present(mean)) then
            mn = mean
        else
            mn = 0.0
        endif

        if (present(std)) then
            st = std
        else
            st = 1.0
        endif

        ! Box-Muller polar method
        do
            ! Generate 2 uniform random numbers between -1.0 and 1.0
            x1 = clim_urand(-1.0, 1.0)
            x2 = clim_urand(-1.0, 1.0)

            ! Check value of w and exit if possible
            w = x1**2 + x2**2
            if (w /= 0.0 .and. w < 1.0) exit
        end do

        ! Calculate y1 and y2 from w, x1, and x2
        w = sqrt((-2.0*log(w))/w)
        y1 = x1*w
        y2 = x2*w

        ! Pick one, adjust its mean and std
        clim_nrand = y1*st + mn

    end function clim_nrand

    !:.........................................................................:

    subroutine set_site_rng_seed(fixed_seed, seed)
        !
        !  Sets the site's random number generator seed. Fixed_seed is for
        !  debugging. If true, we set the seed to be the default seed each time
        !  it is called - this allows for duplication of runs.
        !  If false - we get a random seed, or optionally use an input seed
        !  on the first call.
        !  This also means we can run the sites in any order for serial runs
        !  with fixed_seed on.
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: constants
        integer, parameter :: DEFAULT_SEED = 2345678 ! Default RNG seed

        ! Data dictionary: calling arguments
        logical,        intent(in) :: fixed_seed ! Fixed_seed true?
        real, optional, intent(in) :: seed       ! Optional RNG seed

        ! Data dictionary: local variables
        integer :: idate(8)       ! Array of outputs from date_and_time
        integer :: iseed          ! Local seed
        logical :: first = .true. ! First time we are calling this?

        save

        if (.not. fixed_seed) then

            ! We are not using a fixed seed - need to generate one on first call
            if (first) then

                ! First time we are calling - need to generate a seed

                if (.not. present(seed)) then
                    ! Create seed value
                    ! Get date and time values
                    call date_and_time(values = idate)

                    ! Get a random seed
                    call get_random_seed(iseed)

                    ! Calculate actual seed value
                    if (iseed .ne. 0) then
                        iseed = iseed*idate(8) ! idate(8) = milliseconds
                    else
                        ! If it's 0 somehow, use the default seed
                        iseed = DEFAULT_SEED*idate(8)
                    endif
                else
                    ! use the input seed
                    iseed = seed
                endif

                ! Set first to false, and set rng_seed to generated seed
                first = .false.
                rng_seed = iseed

                ! Set the random seed to the calculated or input seed for any
                ! future random number calls
                call set_random_seed(rng_seed)
            endif
        else
            ! fixed seed - use same seed for all sites. Seed is set to default
            ! seeds unless seed is present in call
            if (.not. present(seed)) then
                ! Use default seed
                iseed = DEFAULT_SEED
            else
                ! Use input seed
                iseed = seed
            endif

            ! Set the seed
            rng_seed = iseed

            ! Set the random number seed
            call set_random_seed(rng_seed)

        endif

    end subroutine set_site_rng_seed

    !:.........................................................................:

    subroutine get_random_seed(seed)
        !
        !  Gets an RGN seed
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        integer, intent(out) :: seed ! RNG seed

        ! Data dictionary: local variables
        integer, dimension(:), allocatable :: iseed ! Array of RNG seeds
        integer                            :: isize ! Max size of seed array

        ! Get max size of random seed
        call random_seed(size = isize)

        ! Allocate iseed to this size
        if (.not. allocated(iseed)) allocate(iseed(isize))

        ! Get a random seed
        call random_seed(get = iseed)
        seed = iseed(1)

    end subroutine get_random_seed

    !:.........................................................................:

    subroutine set_random_seed(seed)
        !
        !  Sets the random seed for random_number calls
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        integer, intent(in) :: seed ! Input RNG seed

        ! Data dictionary: local variables
        integer, dimension(:), allocatable :: iseed ! Array of RNG seeds
        integer                            :: isize ! Max size of RNG seed array

        ! Get size of random seed array and allocate
        call random_seed(size = isize)
        if (.not. allocated(iseed)) allocate(iseed(isize))

        ! Put the seed as the random seed for any future random number calls
        iseed = seed
        call random_seed(put = iseed)

    end subroutine set_random_seed

    !:.........................................................................:

    subroutine shuffle(a)
        !
        !  Shuffles an input integer array
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        integer, dimension(:), intent(inout) :: a ! Array to shuffle

        ! Data dictionary: local variables
        integer :: i       ! Looping index
        integer :: randpos ! Random location in array
        integer :: tempval ! Temporary variable for swapping
        real    :: rnd     ! Random number

        ! Loop backwards through array
        do i = size(a), 1, -1

            ! Call random number
            call random_number(rnd)

            ! Get a random position to swap with
            randpos = int(rnd*i) + 1

            ! Swap values
            tempval = a(randpos)
            a(randpos) = a(i)
            a(i) = tempval
        enddo

    end subroutine shuffle

    !:.........................................................................:

end module Random


    module polygon_clipper
    use polygon_data
    use polygon_writer
    use polygon_reader, only : create_polygon_from_vertices

    implicit none

    real, parameter         :: NODATA = -99999.9
    real, parameter         :: SMALL_REAL = 100. * epsilon(1.)

    contains

    !*********************************************************
    subroutine clipper(clipping_poly, clipped_poly)
    ! https://en.wikipedia.org/wiki/Sutherland%E2%80%93Hodgman_algorithm
    type(Polygon), intent(in)       :: clipping_poly
    type(Polygon), intent(inout)    :: clipped_poly

    integer             :: clipping_size, clipped_size, nverts
    integer             :: iedge, ivert
    type(Vertex), allocatable   :: vertices(:), vertices_out(:)
    type(Vertex)        :: current_point, previous_point, intersecting_point

#ifdef _DEBUG
    character(50)       :: msg
#endif

#ifdef _DEBUG
    call print_polygon(clipped_poly, 'before clipping')
#endif

    clipping_size = clipping_poly%nsides
    clipped_size = clipped_poly%nsides

#ifdef _DEBUG
    write(*,*) 'Number of edges of clipping polygon :: ', clipping_size
    write(*,*) '    Number of edges before clipping :: ', clipped_size
#endif

    vertices = get_vertices_from_polygon(clipped_poly)
    allocate(vertices_out, source = vertices)

    do iedge = 1, clipping_size
        deallocate(vertices)
        allocate(vertices, source = vertices_out)

#ifdef _DEBUG
        write(msg, '(a,x,i0)') 'Iteration', iedge
        call print_list_of_points(vertices_out, msg)
#endif
        deallocate(vertices_out)
        nverts = size(vertices, 1)

        do ivert = 1, nverts
            current_point = vertices(mod(ivert, nverts) + 1)
            previous_point = vertices(ivert)

            intersecting_point = find_intersection(previous_point, current_point, clipping_poly%edges(iedge))

            if (vertex_inside_polygon(current_point, clipping_poly%edges(iedge))) then
                if (.not. vertex_inside_polygon(previous_point, clipping_poly%edges(iedge))) then
                    if (intersecting_point%x > NODATA .and. intersecting_point%y > NODATA) then
                        call append_to_list_of_vertices(vertices_out, intersecting_point)
                    end if
                end if
                call append_to_list_of_vertices(vertices_out, current_point)
            else if (vertex_inside_polygon(previous_point, clipping_poly%edges(iedge))) then

                if (intersecting_point%x > NODATA .and. intersecting_point%y > NODATA) then
                    call append_to_list_of_vertices(vertices_out, intersecting_point)
                end if
            end if
        end do
    end do

    call create_polygon_from_vertices(vertices_out, clipped_poly)
#ifdef _DEBUG
    call print_polygon(clipped_poly, 'after clipping')
#endif
    end subroutine clipper

    !*********************************************************
    function find_intersection(p1, p2, clip_edge) result(int_point)
    ! https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection
    type(Vertex), intent(in)            :: p1, p2
    type(Edge), intent(in)              :: clip_edge
    type(Vertex)                        :: int_point

    real                :: crossproduct
    real                :: t, u
    real                :: x12, y12, x34, y34

    crossproduct = (p2%x - p1%x) * (clip_edge%finish%y - clip_edge%start%y) - (p2%y - p1%y) * (clip_edge%finish%x - clip_edge%start%x)

    if (abs(crossproduct) > SMALL_REAL) then
        x12 = p1%x - p2%x
        y12 = p1%y - p2%y
        x34 = clip_edge%start%x - clip_edge%finish%x
        y34 = clip_edge%start%y - clip_edge%finish%y

        t = ((p1%x - clip_edge%start%x) * y34 - (p1%y - clip_edge%start%y) * x34) / (x12 * y34 - y12 * x34)
        u = ((-x12) * (p1%y - clip_edge%start%y) - (-y12) * (p1%x - clip_edge%start%x)) / (x12 * y34 - y12 * x34)

        ! No need to check it's falling in both line segments, original edge will do
        if (t >= 0.0 .and. t <= 1.0) then
            int_point%x = p1%x + t * (p2%x - p1%x)
            int_point%y = p1%y + t * (p2%y - p1%y)
            return
        end if
    end if

    ! Handle parallel line segments AND point of intersection outside of both line segments
    int_point%x = NODATA
    int_point%y = NODATA
    end function find_intersection

    !*********************************************************
    function vertex_on_edge(vert, clip_edge) result(ok)
    type(Vertex), intent(in)        :: vert
    type(Edge), intent(in)          :: clip_edge
    logical                         :: ok

    real                :: crossproduct, dotproduct, sqlength

    ok = .false.

    crossproduct = (vert%y - clip_edge%start%y) * (clip_edge%finish%x - clip_edge%start%x) - (vert%x - clip_edge%start%x) * (clip_edge%finish%y - vert%y)
    if (crossproduct > epsilon(1.0)) return

    dotproduct = (vert%x - clip_edge%start%x) * (clip_edge%finish%x - clip_edge%start%x) + (vert%y - clip_edge%start%y) * (clip_edge%finish%y - clip_edge%start%y)
    if (dotproduct < 0.0) return

    sqlength = (clip_edge%finish%x - clip_edge%start%x) * (clip_edge%finish%x - clip_edge%start%x) + (clip_edge%finish%y - clip_edge%start%y) * (clip_edge%finish%y - clip_edge%start%y)
    if (dotproduct > sqlength) return

    ok = .true.
    end function vertex_on_edge

    !*********************************************************
    function vertex_inside_polygon(vert, clip_edge) result(ok)
    type(Vertex), intent(in)        :: vert
    type(Edge), intent(in)          :: clip_edge
    logical                         :: ok

    real                :: crossproduct

    ! Assumes counter-clockwise definition of points
    crossproduct = (clip_edge%finish%x - clip_edge%start%x) * (vert%y - clip_edge%start%y) - (clip_edge%finish%y - clip_edge%start%y) * (vert%x - clip_edge%start%x)
    ok = crossproduct >= 0.0
    end function vertex_inside_polygon

    end module polygon_clipper


      subroutine nitsol(n, x, f, jacv, ftol, stptol,
     $     input, info, rwork, rpar, ipar, iterm, dinpr, dnorm)

      implicit none

      integer n, input(10), info(6), ipar(*), iterm
      double precision x(n), ftol, stptol, rwork(*), rpar(*)
      double precision dinpr, dnorm
      external f, jacv, dinpr, dnorm

c
c ------------------------------------------------------------------------
c
c This is nitsol v0.3. The basic algorithm is an inexact Newton method with
c a backtracking globalization; the model is Algorithm INB of S. C. Eisenstat
c and H. F. Walker, "Globally convergent inexact Newton methods", SIAM J.
c Optimization, 4 (1994), pp. 393--422. Initial inexact Newton steps are
c obtained by approximately solving the Newton equation with a transpose-free
c Krylov subspace method; the current choices are GMRES, BiCGSTAB, and
c TFQMR. Jacobian-vector products are evaluated either by finite-difference
c approximation or a user-supplied analytic-evaluation subroutine. An option
c is provided for user-supplied right preconditioning. Left preconditioning
c is not explicitly included as an option, but the user may provide this
c in the subroutines for evaluating the function and Jacobian-vector
c products. Various algorithmic options can be selected through the input
c vector. Optional common blocks are also available for printing diagnostic
c information, passing information about the nonlinear iterations to user
c subroutines, and controlling the behavior of the nonlinear iterations.
c Summary statistics are provided by the info vector on output.
c
c This is the interface subroutine, which calls the driver subroutine nitdrv.
c
c ------------------------------------------------------------------------
c
c Explanation:
c
c  n      = dimension of the problem.
c
c  x      = vector of length n, initial guess on input and final approximate
c           solution on output.
c
c  f      = name of user-supplied subroutine for evaluating the function
c           the zero of which is sought; this routine has the form
c
c                 subroutine f(n, xcur, fcur, rpar, ipar, itrmf)
c
c           where xcur is the array containing the current x value, fcur
c           is f(xcur) on output, rpar and ipar are, respectively, real
c           and integer parameter/work arrays for use by the subroutine,
c           and itrmf is an integer termination flag.  The meaning of
c           itrmf is as follows:
c             0 => normal termination; desired function value calculated.
c             1 => failure to produce f(xcur).
c
c  jacv   = name of user-supplied subroutine for optionally evaluating J*v
c           or P(inverse)*v, where J is the Jacobian of f and P is a
c           right preconditioning operator. If neither analytic J*v
c           evaluations nor right preconditioning is used, this can
c           be a dummy subroutine; if right preconditioning is used but
c           not analytic J*v evaluations, this need only evaluate
c           P(inverse)*v. The form is
c
c           subroutine jacv(n, xcur, fcur, ijob, v, z, rpar, ipar, itrmjv)
c
c           where xcur and fcur are vectors of length n containing the
c           current x and f values, ijob is an integer flag indicating
c           which product is desired, v is a vector of length n to be
c           multiplied, z is a vector of length n containing the desired
c           product on output, rpar and ipar are, respectively, real
c           and integer parameter/work arrays for use by the subroutine,
c           and itrmjv is an integer termination flag. The meaning of
c           ijob is as follows:
c             0 => z = J*v
c             1 => z = P(inverse)*v
c           The meaning of itrmjv is as follows:
c             0 => normal termination; desired product evaluated.
c             1 => failure to produce J*v.
c             2 => failure to produce P(inverse)*v.
c           This subroutine is called only from nitjv, and is always
c           called with v .ne. z.
c
c  ftol   = stopping tolerance on the f-norm.
c
c  stptol = stopping tolerance on the steplength.
c
c  input  = integer vector of length 10 containing various user-specified
c           inputs; see below.
c
c  info   = integer vector of length 6 containing various outputs;
c           see below.
c
c  rwork  = real work vector with length as follows:
c
c             solver    rwork length
c
c             GMRES     n*(kdmax+5)+kdmax*(kdmax+3), where kdmax is the
c                       maximum Krylov subspace dimension, either the
c                       default value of 20 or another value specified
c                       by the user (see input(4) below).
c
c             BiCGSTAB  11*n
c
c             TFQMR     14*n
c
c           The final f-value is contained in the first n components of
c           rwork on return.
c
c  rpar   = real parameter/work array passed to the f and jacv routines.
c
c  ipar   = integer parameter/work array passed to the f and jacv routines.
c
c  iterm   = termination flag; values have the following meanings:
c             -k => illegal value in input(k).
c              0 => normal termination: ||F||.le.ftol or ||step||.le.stptol.
c              1 => nnimax nonlinear iterations reached without success.
c              2 => failure to evaluate F.
c              3 => in nitjv, J*v failure.
c              4 => in nitjv, P(inverse)*v failure.
c              5 => in nitdrv, insufficient initial model norm reduction
c                   for adequate progress. NOTE: This can occur for several
c                   reasons; examine itrmks on return from the Krylov
c                   solver for further information. (This will be printed out
c                   if iplvl .ge. 3; see the discussion of optional
c                   common blocks below).
c              6 => in nitbt, failure to reach an acceptable step through
c                   backtracking.
c
c  dinpr  = name of user-supplied function for calculating vector inner
c           products.  This function must have the form
c
c              xdoty = dinpr( n, x, sx, y, sy )
c
c           where n is the length of the vectors, x and y are the
c           starting locations of the vectors, and sx (sy) is the stride
c           in memory between consecutive elements of x (y).  This is the
c           same signature as the BLAS routine ddot; if the Euclidean
c           inner product is desired the user can link to a local BLAS
c           library and provide the name ddot to nitsol.  dinpr must be
c           declared as an external function that returns a double
c           precision value in the calling program.
c
c  dnorm  = name of user-supplied function for calculating vector norms.
c           This function must have the form
c
c              xnorm = dnorm( n, x, sx )
c
c           where n is the length of the vector, x is the starting
c           location of the vector, and sx is the stride in memory
c           between consecutive elements of x.  This is the same
c           signature as the BLAS routine dnrm2; if the Euclidean
c           norm is desired the user can link to a local BLAS library
c           and provide the name dnrm2 to nitsol.  dnorm must be
c           declared as an external function that returns a double
c           precision value in the calling program.
c
c ------------------------------------------------------------------------
c
c Further explanation of input:
c
c This array allows the user to specify various options. It should be
c declared an integer vector of length 11 in the calling program. To
c specify an option, set the appropriate input component to the desired
c value according to the specifications below.
c
c USAGE NOTE: Setting a particular input component to zero gives the
c default option for that component in all cases.
c
c The first five input components are things that every user might wish
c to modify; the remainder will usually be of interest only to more
c experienced users.
c
c Optional every-user input:
c
c    input(1) = nnimax = maximum number of nonlinear iterations (default 200).
c
c    input(2) = ijacv = flag for determining the method of J*v evaluation:
c                 0 => finite-difference evaluation (default)
c                 1 => analytic evaluation
c
c    input(3) = ikrysl = flag for determining the Krylov solver:
c                 0 => GMRES (default)
c                 1 => BiCGSTAB
c                 2 => TFQMR
c
c               For brief descriptions of the solvers plus references,
c               see the subroutines nitgm, nitstb, and nittfq.
c
c    input(4) = kdmax = maximum Krylov subspace dimension when GMRES is used
c               (default 20).
c
c    input(5) = irpre = flag for right preconditioning:
c                 0 => no right preconditioning
c                 1 => right preconditioning
c
c Optional experienced user input:
c
c    input(6) = iksmax = maximum allowable number of iterations per call
c               to the Krylov solver routine (default 1000).
c
c    input(7) = iresup = residual update flag when GMRES is used; on
c               restarts, the residual is updated as follows:
c                 0 => linear combination (default)
c                 1 => direct evaluation
c               The first is cheap (one n-vector saxpy) but may lose
c               accuracy with extreme residual reduction; the second
c               retains accuracy better but costs one J*v product per
c               restart.
c
c    input(8) = ifdord = order of the finite-difference formula (sometimes)
c               used when input(2) = ijacv = 0. When input(2) = ijacv = 0,
c               this must be 0, 1, 2, or 4 on input; otherwise, it is
c               irrelevant. With input(2) = ijacv = 0, the precise
c               meaning is as follows:
c
c               If GMRES is used, then ifdord matters only if input(7) =
c               iresup = 1, in which case it determines the order of
c               the finite-difference formula used in evaluating the
c               initial residual at each GMRES restart (default 2); if
c               ifdord = 0 on input, then it is set to 2 below. NOTE: This
c               only affects initial residuals at restarts; first-order
c               differences are always used within each GMRES cycle. Using
c               higher-order differences at restarts only should give
c               the same accuracy as if higher-order differences were
c               used throughout; see K. Turner and H. F. Walker, "Efficient
c               high accuracy solutions with GMRES(m)," SIAM J. Sci.
c               Stat. Comput., 13 (1992), pp. 815--825.
c
c               If BiCGSTAB or TFQMR is used, then ifdord determines the
c               order of the finite-difference formula used at each
c               iteration (default 1); if ifdord = 0 on input, then it
c               is set to 1 below.
c
c    input(9) = ibtmax = maximum allowable number of backtracks (step
c               reductions) per call to nitbt (default 10).
c
c               USAGE NOTE: Backtracking can be turned off by setting
c		ibtmax = -1. Other negative values of ibtmax are not
c               valid.
c
c    input(10) = ieta = flag determining the forcing term eta as follows:
c                 0 => abs( ||fcur|| - ||fprev+Jprev*sprev|| )/||fprev||
c                      (default)
c                 1 => (||fcur||/||fprev||)**2
c                 2 => gamma*(||fcur||/||fprev||)**alpha
c                      for user-supplied gamma in (0,1] and alpha in (1,2]
c                 3 => fixed (constant) eta in (0,1), either 0.1 (default)
c		       or specified by the user (see USAGE NOTE below)
c               Here, fcur = current f, fprev = previous f, etc. The Krylov
c               iterations are terminated when an iterate s satisfies
c               an inexact Newton condition ||F + J*s|| .le. eta*||F||.
c
c               USAGE NOTE: If input(10) = ieta = 2, then alpha and gamma
c               must be set in common block nitparam.h as described below.
c		If input(10) = ieta = 3, then the desired constant eta may
c		be similarly set in nitparam.h if a value other than the
c		default of 0.1 is desired.
c
c               The first three expressions above are from S. C. Eisenstat
c               and H. F. Walker, "Choosing the forcing terms in an inexact
c               Newton method", SIAM J. Scientific Computing, 17 (1996),
c               pp. 16--32. (They may be modified according to certain
c               safeguards in subroutine nitdrv.) The first gives convergence
c               that is q-superlinear and of r-order (1+sqrt(5))/2. The
c               second gives convergence that is r-quadratic and of q-order
c               p for every p in [1,2). The third gives convergence that is
c               of q-order alpha when gamma < 1 and, when gamma = 1, of
c               r-order alpha and q-order p for every p in [1,alpha). The
c               fourth gives q-linear convergence with asymptotic rate
c               constant eta in a certain norm; see R. S. Dembo, S. C.
c		Eisenstat, and T. Steihaug, "Inexact Newton methods",
c               SIAM J. Numer. Anal., 18 (1982), pp. 400-408.
c
c               Of these four choices, the 1st is usually satisfactory,
c               the 2nd or 3rd is sometimes preferred, and the 4th may be
c               useful in some situations, e.g., it may be desirable to
c               choose a fairly large fixed eta in (0,1), such as eta = .1,
c               when numerical inaccuracy prevents the Krylov solver
c               from obtaining much residual reduction.
c
c ------------------------------------------------------------------------
c
c Further explanation of info: On output, the components of info are
c as follows:
c
c     info(1)   = nfe (number of function evaluations)
c     info(2)   = njve (number of J*v evaluations)
c     info(3)   = nrpre (number of P(inverse)*v evaluations)
c     info(4)   = nli (number of linear iterations)
c     info(5)   = nni (number of nonlinear iterations)
c     info(6)   = nbt (number of backtracks)
c
c ------------------------------------------------------------------------
c
c Optional common blocks:
c
c These can be used to control printing of diagnostic information by nitsol,
c to pass information about the nonlinear iterations to jacv or other user
c subroutines, or to control the default behavior of the nonlinear iterations.
c
c For controlling printing of diagnostic information:
c
      include 'nitprint.h'
c
c If diagnostic information is desired, include this common block in the
c main program and set iplvl and ipunit according to the following:
c
c     iplvl = 0 => no printout
c           = 1 => iteration numbers and F-norms
c           = 2 => ... + some stats, step norms, and linear model norms
c           = 3 => ... + some Krylov solver and backtrack information
c           = 4 => ... + more Krylov solver and backtrack information
c
c     ipunit = printout unit number, e.g., ipunit = 6 => standard output.
c              NOTE: If ipunit = 0 on input, then it is set to 6 below.
c
c For passing information about the nonlinear iterations to user-supplied
c subroutines:
c
      include 'nitinfo.h'
c
c If information on the current state of the nonlinear iteration is
c desired in a user-supplied subroutine (for example, deciding
c whether to update a preconditioner), include this common block
c in the subroutine. The variables are as follows:
c
c     instep - inexact Newton step number.
c
c    newstep - set to 0 at the beginning of an inexact Newton step.
c              This may be checked in a user-supplied jacv to decide
c              whether to update the preconditioner.  If you test on
c              newstep .eq. 0 to determine whether to take some
c              special action at the beginning of a nonlinear iteration,
c              you must also set newstep to some nonzero value to
c              subsequently avoid taking that action unnecessarily.
c
c    krystat - status of the Krylov iteration; same as itrmks (see
c              the nitsol documentation).
c
c    avrate  - average rate of convergence of the Krylov solver during
c              the previous inexact Newton step.  This may be checked
c              in a user-supplied jacv to decide when to update the
c              preconditioner.
c
c    fcurnrm - ||f(xcur)||.
c
c        eta - forcing term.
c
c
c  For controlling the default behavior of the nonlinear iterations:
c
      include 'nitparam.h'

c nitparam contains some parameters that control the nonlinear
c iterations.  In some cases, the default values reflect prevailing
c practice; in other cases, they are chosen to produce good
c average-case behavior.  To change the default values, include this
c common block in the main program and set the desired variables
c according to the following:
c
c    choice1_exp -  parameter used in the update of the forcing term
c                   eta when ieta = 0 (default).  This is the exponent
c                   for determining the etamin safeguard.  The default
c                   value is choice1_exp = (1+sqrt(5))/2.  A larger
c                   value will allow eta to decrease more rapidly,
c                   while a smaller value will result in a larger
c                   value for the safeguard.
c
c    choice2_exp  - parameter used in the update of the forcing term
c                   eta when ieta = 2.  This is the exponent alpha
c		    in the expression gamma*(||fcur||/||fprev||)**alpha;
c		    it is also used to determine the etamin safeguard.
c		    The default value is 2.0. Valid values are in the
c		    range (1.0, 2.0].
c
c    choice2_coef - parameter used in the update of the forcing term eta
c                   when ieta = 2.  This is the coefficient gamma used
c		    in the expression gamma*(||fcur||/||fprev||)**alpha;
c                   it is also used to determine the etamin safeguard.
c                   The default value is 1.0. Valid values are in the
c		    range (0.0, 1.0].
c
c    eta_cutoff   - parameter used to determine when to disable
c                   safeguarding the update of the forcing term.  It
c                   only has meaning when ieta .ne. 3.  The default
c                   value is 0.1.  A value of 0.0 will enable
c		    safeguarding always; a value of 1.0 will disable
c		    safeguarding always.
c
c    etamax       - parameter used to provide an upper bound on the
c		    forcing terms when input(10) .ne. 3. This is
c		    necessary to ensure convergence of the inexact Newton
c		    iterates and is imposed whenever eta would otherwise
c		    be too large. (An overly large eta can result from
c		    the updating formulas when input(10) .ne. 3 or from
c                   safeguarding when the previous forcing term has been
c		    excessively increased during backtracking.) The
c		    default value of etamax is 1.0 - 1.e-4.  When
c		    backtracking occurs several times during a nonlinear
c		    solve the forcing term can remain near etamax for several
c                   nonlinear steps and cause the nonlinear iterations
c                   to nearly stagnate.  In such cases a smaller value of
c                   etamax may prevent this.  Valid values are in the
c                   range (0.0, 1.0).
c
c    etafixed     - this is the user-supplied fixed eta when ieta = 3.
c                   The  default value is etafixed = 0.1.  Valid values
c                   are in the range (0.0,1.0).
c
c    thmin        - when backtracking occurs, this is the smallest
c                   reduction factor that will be applied to the current
c                   step in a single backtracking reduction.  The default
c                   value is 0.1.  Valid  values are in the range
c                   [0.0, thmax].
c
c    thmax        - when backtracking occurs, this is the largest
c                   reduction factor that will be applied to the current
c                   step in a single backtracking reduction.  The default
c                   value is 0.5.  Valid values are in the range
c                   [thmin, 1.0).
c
c  The values in this common block are checked once here in nitsol
c  before the main solution driver is called.  If any parameter has
c  an invalid value, it is silently reset to the default value.
c
c ------------------------------------------------------------------------
c
c Subroutines required by this and all called routines:
c
c     user supplied: f, jacv, dinpr, dnorm
c
c     nitsol routines: nitbd.f, nitbt, nitdrv, nitgm, nitjv, nitstb, nittfq
c
c     lapack routines: dlaic1, dlamch.f
c
c     blas routines: daxpy, dcopy, dscal, dswap
c
c This subroutine called by: calling program
c
c Subroutines called by this subroutine: nitdrv
c
c ------------------------------------------------------------------------
c
c Remaining declarations:
c
      integer ibtmax, ieta, ifdord, ijacv, ikrysl, iksmax, iresup,
     $     irpre, kdmax, lfcur, lfpls, lrwork, lstep, lxpls,
     $     nbt, nfe, njve, nli, nni, nnimax, nrpre

      include 'nitdflts.h'

      external nitbd

c ------------------------------------------------------------------------
c
c Begin executable code.
c
c ------------------------------------------------------------------------
c Check inputs and initialize parameters.
c ------------------------------------------------------------------------
      if (ipunit .gt. 6) open( unit=ipunit, status='unknown' )
      if (ipunit .eq. 0) ipunit = 6
      if (input(1) .eq. 0) then
         nnimax = 200
      else
         if (input(1) .gt. 0) then
            nnimax = input(1)
         else
            iterm = -1
            go to 900
         endif
      endif
      if (input(2) .eq. 0 .or. input(2) .eq. 1) then
         ijacv = input(2)
      else
         iterm = -2
         go to 900
      endif
      if (input(3) .ge. 0 .and. input(3) .le. 2) then
         ikrysl = input(3)
      else
         iterm = -3
         go to 900
      endif
      if (ikrysl .eq. 0) then
         if (input(4) .eq. 0) then
            kdmax = 20
         else
            if (input(4) .gt. 0) then
               kdmax = input(4)
            else
               iterm = -4
               go to 900
            endif
         endif
      endif
      if (input(5) .eq. 0 .or. input(5) .eq. 1) then
         irpre = input(5)
      else
         iterm = -5
         go to 900
      endif
      if (input(6) .eq. 0) then
         iksmax = 1000
      else
         if (input(6) .gt. 0) then
            iksmax = input(6)
         else
            iterm = -6
            go to 900
         endif
      endif
      if (ikrysl .eq. 0) then
         if (input(7) .eq. 0 .or. input(7) .eq. 1) then
            iresup = input(7)
         else
            iterm = -7
            go to 900
         endif
      endif
      if (ijacv .eq. 0) then
         if (input(8) .eq. 0) then
            if (ikrysl .eq. 0) then
               ifdord = 2
            else
               ifdord = 1
            endif
         else
            if (input(8) .eq. 1 .or. input(8) .eq. 2 .or.
     $           input(8) .eq. 4) then
               ifdord = input(8)
            else
               iterm = -8
               go to 900
            endif
         endif
      endif
      if (input(9) .eq. 0) then
         ibtmax = 10
      else
         if (input(9) .gt. 0 .or. input(9) .eq. -1) then
            ibtmax = input(9)
         else
            iterm = -9
            go to 900
         endif
      endif
      if (input(10) .ge. 0 .and. input(10) .le. 3) then
         ieta = input(10)
      else
         iterm = -10
         go to 900
      endif
c ------------------------------------------------------------------------
c  Check possible invalid value for printout level.  In
c  case the value is invalid the default is restored.
c ------------------------------------------------------------------------
      if ( iplvl .lt. 0 .or. iplvl .gt. 4 ) iplvl = DFLT_PRLVL
c ------------------------------------------------------------------------
c  Check possible invalid values for various parameters.  In
c  case the values are invalid the defaults are restored.
c ------------------------------------------------------------------------
      if ( choice1_exp .le. 1.0d0 .or. choice1_exp .gt. 2.0d0 )
     &  choice1_exp = DFLT_CHOICE1_EXP
      if ( choice2_exp .le. 1.0d0 .or. choice2_exp .gt. 2.0d0 )
     &  choice2_exp = DFLT_CHOICE2_EXP
      if ( choice2_coef .lt. 0.0d0 .or. choice2_coef .gt. 1.0d0 )
     &  choice2_coef = DFLT_CHOICE2_COEF
      if ( etamax .le. 0.0d0 ) etamax = DFLT_ETA_MAX
      if ( thmin .lt. 0.0d0 .or. thmin .gt. thmax )
     &  thmin = DFLT_THMIN
      if ( thmax .gt. 1.0d0 .or. thmax .lt. thmin )
     &  thmax = DFLT_THMAX
c ------------------------------------------------------------------------
c  Initialize some pointers into the rwork array.
c ------------------------------------------------------------------------
      lfcur = 1
      lxpls = lfcur + n
      lfpls = lxpls + n
      lstep = lfpls + n
      lrwork = lstep + n
c ------------------------------------------------------------------------
c Call nitdrv.
c ------------------------------------------------------------------------
      call nitdrv(n, x, rwork(lfcur), rwork(lxpls), rwork(lfpls),
     $        rwork(lstep), f, jacv, rpar, ipar, ftol, stptol, nnimax,
     $        ijacv, ikrysl, kdmax, irpre, iksmax, iresup, ifdord,
     $        ibtmax, ieta, iterm, nfe, njve, nrpre, nli, nni, nbt,
     $        rwork(lrwork), dinpr, dnorm)
c ------------------------------------------------------------------------
c Set output for return.
c ------------------------------------------------------------------------
      info(1) = nfe
      info(2) = njve
      info(3) = nrpre
      info(4) = nli
      info(5) = nni
      info(6) = nbt
c ------------------------------------------------------------------------
c All returns made here.
c ------------------------------------------------------------------------
 900  continue
      if ( ipunit .gt. 6 ) close( unit=ipunit )
      return
      end
c -------------------- end of subroutine nitsol  --------------------------