!| The `numeric_nonNumber` module provides constants and procedures related to not-a-number and infinity.
!
! The constants include the quiet nan and positive/negative inf
! in the 4- and 8-byte floating point number types provided by the Fortran standard.
! 16-byte floating point number type is not supported yet.
!
! The procedures include functions to check whether a floating-point number is a quiet nan, positive/negative inf
! and whether an array of floating-point numbers has at least one quiet nan, positive/negative inf value.
!
module numeric_nonNumber
    use, intrinsic :: iso_fortran_env
    use, intrinsic :: ieee_arithmetic
    use :: numeric_real, only:result_type_real32, result_type_real64
    implicit none
    private
    public :: has_nan
    public :: is_positive_inf
    public :: is_negative_inf
    public :: is_inf
    public :: has_inf
    public :: is_non_number
    public :: has_non_number

    integer(int32), private, parameter :: Real32_Quiet_NaN_To_Int32 = -4194304_int32
        !! The integer representation of a binary representation of 4-byte floating-point quiet nan.

        !! It is confirmed by executing the code below:
        !!```Fortran
        !!print *, transfer(ieee_value(result_type_real32, ieee_quiet_nan), result_type_int32)
        !!```
    integer(int32), private, parameter :: Real32_Positive_Inf_To_Int32 = 2139095040_int32
        !! The integer representation of a binary representation of 4-byte floating-point positive inf.

        !! It is confirmed by executing the code below:
        !!```Fortran
        !!print *, transfer(ieee_value(result_type_real32, ieee_positive_inf), result_type_int32)
        !!```
    integer(int32), private, parameter :: Real32_Negative_Inf_To_Int32 = -8388608_int32
        !! The integer representation of a binary representation of 4-byte floating-point negative inf.

        !! It is confirmed by executing the code below:
        !!```Fortran
        !!print *, transfer(ieee_value(result_type_real32, ieee_negative_inf), result_type_int32)
        !!```
    integer(int64), private, parameter :: Real64_Quiet_NaN_To_Int64 = -2251799813685248_int64
        !! The integer representation of a binary representation of 8-byte floating-point quiet nan.

        !! It is confirmed by executing the code below:
        !!```Fortran
        !!print *, transfer(ieee_value(result_type_real64, ieee_quiet_nan), result_type_int64)
        !!```
    integer(int64), private, parameter :: Real64_Positive_Inf_To_Int64 = 9218868437227405312_int64
        !! The integer representation of a binary representation of 8-byte floating-point positive inf.

        !! It is confirmed by executing the code below:
        !!```Fortran
        !!print *, transfer(ieee_value(result_type_real64, ieee_positive_inf), result_type_int64)
        !!```
    integer(int64), private, parameter :: Real64_Negative_Inf_To_Int64 = -4503599627370496_int64
        !! The integer representation of a binary representation of 8-byte floating-point negative inf.

        !! It is confirmed by executing the code below:
        !!```Fortran
        !!print *, transfer(ieee_value(result_type_real64, ieee_negative_inf), result_type_int64)
        !!```

    ! The type conversion by intrinsic function such as `real(Z'FFC00000', real32)` shows range-check warning
    real(real32), public, parameter :: Real32_Quiet_NaN = transfer(Real32_Quiet_NaN_To_Int32, result_type_real32)
        !! 4-byte floating-point quiet nan.
    real(real32), public, parameter :: Real32_Positive_Inf = transfer(Real32_Positive_Inf_To_Int32, result_type_real32)
        !! 4-byte floating-point positive inf.
    real(real32), public, parameter :: Real32_Negative_Inf = transfer(Real32_Negative_Inf_To_Int32, result_type_real32)
        !! 4-byte floating-point negative inf.

    real(real64), public, parameter :: Real64_Quiet_NaN = transfer(Real64_Quiet_NaN_To_Int64, result_type_real64)
        !! 8-byte floating-point quiet nan.
    real(real64), public, parameter :: Real64_Positive_Inf = transfer(Real64_Positive_Inf_To_Int64, result_type_real64)
        !! 8-byte floating-point positive inf.
    real(real64), public, parameter :: Real64_Negative_Inf = transfer(Real64_Negative_Inf_To_Int64, result_type_real64)
        !! 8-byte floating-point negative inf.

    !| Returns `.true.` if an array of floating-point numbers has at least one nan.
    interface has_nan
        procedure :: has_nan_real32_rank1
        procedure :: has_nan_real32_rank2
        procedure :: has_nan_real32_rank3
        procedure :: has_nan_real64_rank1
        procedure :: has_nan_real64_rank2
        procedure :: has_nan_real64_rank3
    end interface

    !|  Returns `.true.` when a floating-point number is positive inf
    interface is_positive_inf
        procedure :: is_positive_inf_real32
        procedure :: is_positive_inf_real64
    end interface

    !|  Returns `.true.` when a floating-point number is negative inf
    interface is_negative_inf
        procedure :: is_negative_inf_real32
        procedure :: is_negative_inf_real64
    end interface

    !|  Returns `.true.` when a floating-point number is positive or negative inf
    interface is_inf
        procedure :: is_inf_real32
        procedure :: is_inf_real64
    end interface

    !| Returns `.true.` if an array of floating-point numbers has at least one positive or negative inf.
    interface has_inf
        procedure :: has_inf_real32_rank1
        procedure :: has_inf_real32_rank2
        procedure :: has_inf_real32_rank3
        procedure :: has_inf_real64_rank1
        procedure :: has_inf_real64_rank2
        procedure :: has_inf_real64_rank3
    end interface

    !|  Returns `.true.` when a floating-point number is quiet nan, positive inf, or negative inf
    interface is_non_number
        procedure :: is_non_number_real32
        procedure :: is_non_number_real64
    end interface

    !| Returns `.true.` if an array of floating-point numbers has at least one quiet nan, positive, or negative inf.
    interface has_non_number
        procedure :: has_non_number_real32_rank1
        procedure :: has_non_number_real32_rank2
        procedure :: has_non_number_real32_rank3
        procedure :: has_non_number_real64_rank1
        procedure :: has_non_number_real64_rank2
        procedure :: has_non_number_real64_rank3
    end interface
contains
    !| Returns `.true.` if rank 1 4-byte floating-point number array has at least one quiet nan.
    function has_nan_real32_rank1(array) result(is_nan_contained)
        implicit none

        real(real32), intent(in) :: array(:)
            !! rank 1 4-byte floating point number array

        logical :: is_nan_contained

        is_nan_contained = any(ieee_is_nan(array))
    end function has_nan_real32_rank1

    !| Returns `.true.` if rank 2 4-byte floating-point number array has at least one quiet nan.
    function has_nan_real32_rank2(array) result(is_nan_contained)
        implicit none

        real(real32), intent(in) :: array(:, :)
            !! arank 2 4-byte floating point number array

        logical :: is_nan_contained

        is_nan_contained = any(ieee_is_nan(array))
    end function has_nan_real32_rank2

    !| Returns `.true.` if rank 3 4-byte floating-point number array has at least one quiet nan.
    function has_nan_real32_rank3(array) result(is_nan_contained)
        implicit none

        real(real32), intent(in) :: array(:, :, :)
            !! rank 3 4-byte floating point number array

        logical :: is_nan_contained

        is_nan_contained = any(ieee_is_nan(array))
    end function has_nan_real32_rank3

    !| Returns `.true.` if rank 1 8-byte floating-point number array has at least one quiet nan.
    function has_nan_real64_rank1(array) result(is_nan_contained)
        implicit none

        real(real64), intent(in) :: array(:)
            !! rank 1 8-byte floating point number array

        logical :: is_nan_contained

        is_nan_contained = any(ieee_is_nan(array))
    end function has_nan_real64_rank1

    !| Returns `.true.` if rank 2 8-byte floating-point number array has at least one quiet nan.
    function has_nan_real64_rank2(array) result(is_nan_contained)
        implicit none

        real(real64), intent(in) :: array(:, :)
            !! a rank 2 8-byte floating point number array

        logical :: is_nan_contained

        is_nan_contained = any(ieee_is_nan(array))
    end function has_nan_real64_rank2

    !| Returns `.true.` if rank 3 8-byte floating-point number array has at least one quiet nan.
    function has_nan_real64_rank3(array) result(is_nan_contained)
        implicit none

        real(real64), intent(in) :: array(:, :, :)
            !! rank 3 8-byte floating point number array

        logical :: is_nan_contained

        is_nan_contained = any(ieee_is_nan(array))
    end function has_nan_real64_rank3

    !------------------------------------------------------------------!
    !| Returns `.true.` when a 4-byte floating-point number is positive inf
    elemental function is_positive_inf_real32(r32) result(is_positive_infinity)
        implicit none

        real(real32), intent(in) :: r32
            !! 4-byte floating-point number

        logical :: is_positive_infinity

        logical :: check_passed(3)
        check_passed(:) = .false.

        ! 1. the value is equal to positive infinity
        if (r32 == ieee_value(r32, ieee_positive_inf)) then
            check_passed(1) = .true.
        end if

        ! 2. the value subtracted 1 is equal to positive infinity
        if (r32 - 1 == ieee_value(r32, ieee_positive_inf)) then
            check_passed(2) = .true.
        end if

        ! 3. the value is greater than the positive maximum value
        if (r32 > huge(result_type_real32)) then
            check_passed(3) = .true.
        end if

        is_positive_infinity = all(check_passed)
    end function is_positive_inf_real32

    !| Returns `.true.` when an 8-byte floating-point number is positive inf
    elemental function is_positive_inf_real64(r64) result(is_positive_infinity)
        implicit none

        real(real64), intent(in) :: r64
            !! 8-byte floating-point number

        logical :: is_positive_infinity
        logical :: check_passed(3)

        check_passed(:) = .false.

        ! 1. the value is equal to positive infinity
        if (r64 == ieee_value(r64, ieee_positive_inf)) then
            check_passed(1) = .true.
        end if

        ! 2. the value subtracted 1 is equal to positive infinity
        if (r64 - 1 == ieee_value(r64, ieee_positive_inf)) then
            check_passed(2) = .true.
        end if

        ! 3. the value is greater than the positive maximum value
        if (r64 > huge(result_type_real64)) then
            check_passed(3) = .true.
        end if

        is_positive_infinity = all(check_passed)
    end function is_positive_inf_real64

    !| Returns `.true.` when a 4-byte floating-point number is negative inf
    elemental function is_negative_inf_real32(r32) result(is_negative_infinity)
        implicit none

        real(real32), intent(in) :: r32
            !! 4-byte floating-point number

        logical :: is_negative_infinity
        logical :: check_passed(3)

        check_passed(:) = .false.

        ! 1. the value is equal to negative infinity
        if (r32 == ieee_value(r32, ieee_negative_inf)) then
            check_passed(1) = .true.
        end if

        ! 2. the value added 1 is equal to negative infinity
        if (r32 + 1 == ieee_value(r32, ieee_negative_inf)) then
            check_passed(2) = .true.
        end if

        ! 3. the value is less than the negative maximum value
        if (r32 < -huge(result_type_real32)) then
            check_passed(3) = .true.
        end if

        is_negative_infinity = all(check_passed)
    end function is_negative_inf_real32

    !| Returns `.true.` when an 8-byte floating-point number is negative inf
    elemental function is_negative_inf_real64(r64) result(is_negative_infinity)
        implicit none

        real(real64), intent(in) :: r64
            !! 8-byte floating-point number

        logical :: is_negative_infinity
        logical :: check_passed(3)

        check_passed(:) = .false.

        ! 1. the value is equal to negative infinity
        if (r64 == ieee_value(r64, ieee_negative_inf)) then
            check_passed(1) = .true.
        end if

        ! 2. the value added 1 is equal to negative infinity
        if (r64 + 1 == ieee_value(r64, ieee_negative_inf)) then
            check_passed(2) = .true.
        end if

        ! 3. the value is less than the negative maximum value
        if (r64 < -huge(result_type_real64)) then
            check_passed(3) = .true.
        end if

        is_negative_infinity = all(check_passed)
    end function is_negative_inf_real64

    !------------------------------------------------------------------!
    !|  Returns `.true.` when 4-byte floating-point number is positive or negative inf
    elemental function is_inf_real32(r32) result(is_infinity)
        implicit none

        real(real32), intent(in) :: r32
            !! 4-byte floating-point number

        logical :: is_infinity
        logical :: check_passed(2)

        check_passed(1) = is_positive_inf(r32)
        check_passed(2) = is_negative_inf(r32)

        is_infinity = any(check_passed)
    end function is_inf_real32

    !|  Returns `.true.` when 8-byte floating-point number is positive or negative inf!|
    elemental function is_inf_real64(r64) result(is_infinity)
        implicit none

        real(real64), intent(in) :: r64
            !! 8-byte floating-point number

        logical :: is_infinity
        logical :: check_passed(2)

        check_passed(1) = is_positive_inf(r64)
        check_passed(2) = is_negative_inf(r64)

        is_infinity = any(check_passed)
    end function is_inf_real64

    !------------------------------------------------------------------!
    !| Returns `.true.` if rank 1 4-byte floating-point number array has at least one positive or negative inf.
    function has_inf_real32_rank1(array) result(is_inf_contained)
        implicit none

        real(real32), intent(in) :: array(:)
            !! rank 1 4-byte floating-point number

        logical :: is_inf_contained

        is_inf_contained = any(is_inf(array))
    end function has_inf_real32_rank1

    !| Returns `.true.` if rank 2 4-byte floating-point number array has at least one positive or negative inf.
    function has_inf_real32_rank2(array) result(is_inf_contained)
        implicit none

        real(real32), intent(in) :: array(:, :)
            !! rank 2 4-byte floating-point number

        logical :: is_inf_contained

        is_inf_contained = any(is_inf(array))
    end function has_inf_real32_rank2

    !| Returns `.true.` if rank 3 4-byte floating-point number array has at least one positive or negative inf.
    function has_inf_real32_rank3(array) result(is_inf_contained)
        implicit none

        real(real32), intent(in) :: array(:, :, :)
            !! rank 3 4-byte floating-point number

        logical :: is_inf_contained

        is_inf_contained = any(is_inf(array))
    end function has_inf_real32_rank3

    !| Returns `.true.` if rank 1 8-byte floating-point number array has at least one positive or negative inf.
    function has_inf_real64_rank1(array) result(is_inf_contained)
        implicit none

        real(real64), intent(in) :: array(:)
            !! rank 1 8-byte floating-point number

        logical :: is_inf_contained

        is_inf_contained = any(is_inf(array))
    end function has_inf_real64_rank1

    !| Returns `.true.` if rank 2 8-byte floating-point number array has at least one positive or negative inf.
    function has_inf_real64_rank2(array) result(is_inf_contained)
        implicit none

        real(real64), intent(in) :: array(:, :)
            !! rank 2 8-byte floating-point number

        logical :: is_inf_contained

        is_inf_contained = any(is_inf(array))
    end function has_inf_real64_rank2

    !| Returns `.true.` if rank 3 8-byte floating-point number array has at least one positive or negative inf.
    function has_inf_real64_rank3(array) result(is_inf_contained)
        implicit none

        real(real64), intent(in) :: array(:, :, :)
            !! rank 3 8-byte floating-point number

        logical :: is_inf_contained

        is_inf_contained = any(is_inf(array))
    end function has_inf_real64_rank3

    !------------------------------------------------------------------!
    !| Returns `.true.` when 4-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    elemental logical function is_non_number_real32(r32)
        implicit none

        real(real32), intent(in) :: r32
            !! 4-byte floating-point number

        logical :: check_passed(3)

        check_passed(1) = is_positive_inf(r32)
        check_passed(2) = is_negative_inf(r32)
        check_passed(3) = ieee_is_nan(r32)

        is_non_number_real32 = any(check_passed)
    end function is_non_number_real32

    !| Returns `.true.` when 8-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    elemental logical function is_non_number_real64(r64)
        implicit none

        real(real64), intent(in) :: r64
            !! 8-byte floating-point number

        logical :: check_passed(3)

        check_passed(1) = is_positive_inf(r64)
        check_passed(2) = is_negative_inf(r64)
        check_passed(3) = ieee_is_nan(r64)

        is_non_number_real64 = any(check_passed)
    end function is_non_number_real64

    !| Returns `.true.` if rank 1 4-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    function has_non_number_real32_rank1(array) result(is_non_number_contained)
        implicit none

        real(real32), intent(in) :: array(:)
           !! rank 1 4-byte floating-point number

        logical :: is_non_number_contained

        is_non_number_contained = any(is_non_number(array))
    end function has_non_number_real32_rank1

    !| Returns `.true.` if rank 2 4-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    function has_non_number_real32_rank2(array) result(is_non_number_contained)
        implicit none

        real(real32), intent(in) :: array(:, :)
           !! rank 2 4-byte floating-point number

        logical :: is_non_number_contained

        is_non_number_contained = any(is_non_number(array))
    end function has_non_number_real32_rank2

    !| Returns `.true.` if rank 3 4-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    function has_non_number_real32_rank3(array) result(is_non_number_contained)
        implicit none

        real(real32), intent(in) :: array(:, :, :)
           !! rank 3 4-byte floating-point number

        logical :: is_non_number_contained

        is_non_number_contained = any(is_non_number(array))
    end function has_non_number_real32_rank3

    !| Returns `.true.` if rank 1 8-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    function has_non_number_real64_rank1(array) result(is_non_number_contained)
        implicit none

        real(real64), intent(in) :: array(:)
           !! rank 1 8-byte floating-point number

        logical :: is_non_number_contained

        is_non_number_contained = any(is_non_number(array))
    end function has_non_number_real64_rank1

    !| Returns `.true.` if rank 2 8-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    function has_non_number_real64_rank2(array) result(is_non_number_contained)
        implicit none

        real(real64), intent(in) :: array(:, :)
            !! rank 2 8-byte floating-point number

        logical :: is_non_number_contained

        is_non_number_contained = any(is_non_number(array))
    end function has_non_number_real64_rank2

    !| Returns `.true.` if rank 3 8-byte floating-point number array has at least one quiet nan, positive, or negative inf.
    function has_non_number_real64_rank3(array) result(is_non_number_contained)
        implicit none

        real(real64), intent(in) :: array(:, :, :)
            !! rank 3 8-byte floating-point number

        logical :: is_non_number_contained

        is_non_number_contained = any(is_non_number(array))
    end function has_non_number_real64_rank3
end module numeric_nonNumber


program EC_rotate_xyz
!  Rotate all ECs in an input .xyz EC file.
!  Number of ECs is determined by inspection, rather than stated on command line.
!  a, b and g are angles about x1, x2, x3 as stated in anisotropy_ajn: CIJ_rot3

use constants
use anisotropy_ajn
use EC_grid

type(ECgrid)       :: grid
real(rs)           :: C(6,6),Ctemp(6,6),a,b,g
character(len=250) :: fname
integer            :: kx,ky,kz

!  Process command line options
if (command_argument_count() /= 4) then
   write(0,*) 'Usage: EC_rot3 [alpha] [beta] [gamma] [.xyz file] > [output file]'
   stop
endif

call get_command_argument(1,fname); read(fname,*) a
call get_command_argument(2,fname); read(fname,*) b
call get_command_argument(3,fname); read(fname,*) g

call get_command_argument(4,fname)

!  Work out how many elastic constants we're dealing with
necs = EC_grid_check_necs(fname)

!  Read in ecs
call EC_grid_load(fname,grid,necs=necs,quiet=.true.)

!  Rotate ecs
do k1 = 1, grid % nx
   do k2 = 1, grid % ny
      do k3 = 1, grid % nz
         call CIJ_rot3(grid%ecs(k1,k2,k3,:,:),a,b,g,Ctemp)
         grid%ecs(k1,k2,k3,:,:) = Ctemp
      enddo
   enddo
enddo

!  Write ecs out to stdout
call EC_grid_dump(grid,necs=21)

end program EC_rotate_xyz


c     ============================================
      subroutine setaux(mbc,mx,xlower,dx,maux,aux)
c     ============================================
c
c     # set auxiliary arrays
c     # variable coefficient acoustics
c     #  aux(i,1) = impedance Z in i'th cell
c
c     # Piecewise constant medium with single interface at x=0
c     # Density and sound speed to left and right are set in setprob.f
c
      implicit none

      integer, intent(in) :: mbc, mx, maux
      double precision, intent(in) :: xlower, dx
      double precision, intent(out) :: aux
      dimension aux(maux, 1-mbc:mx+mbc)

      integer i
      double precision xcell, u, mu1, mu2, mu3, mu4, pi

      common /cparam/ mu1,mu2,mu3,mu4

      pi = 4.0d0*datan(1.0d0)

      do i=1-mbc,mx+mbc
       xcell = xlower + (i-0.5d0)*dx
       aux(1,i) = 1.5d0 + mu1*dsin(mu2*xcell)
       aux(1,i) = aux(1,i) + 0.1d0*dcos(mu3*xcell)
      enddo

      return
      end


! Harmonic Series

! How We Got From There To Here:
! A Story of Real Analysis
! page 130 - 132

      program harSer
         implicit none
         integer :: n
         integer, parameter :: rp = selected_real_kind(15)
         integer :: i
         Real (kind = rp) :: a
         n = 1000000000
         a = 0.0_rp
         do i = 1,n,1
            a = (a + (1.0_rp/i))
         end do
         print *, a
      end program harSer


module quadprog_ng_redo
  implicit none
contains
  subroutine do_cholesky_and_inverse(rank_A, in_mat_A, out_mat_L, out_mat_Inv)
    implicit none
    integer, intent(in) :: rank_A
    real(8), allocatable, intent(in) :: in_mat_A(:,:)
    real(8), allocatable, intent(inout) :: out_mat_L(:,:), out_mat_Inv(:,:)

    integer :: irow, icol = 0
    real(8), allocatable :: mat_U(:,:)

    integer :: ierr

    allocate(mat_U(rank_A, rank_A))

    if (.not. allocated(out_mat_L)) then
      allocate(out_mat_L(rank_A, rank_A))
      out_mat_L = 0
    endif

    if (.not. allocated(out_mat_Inv)) then
      allocate(out_mat_Inv(rank_A, rank_A))
      out_mat_Inv = 0
    endif

    out_mat_L = in_mat_A
    mat_U = in_mat_A

    call dpotrf('L', rank_A, out_mat_L, rank_A, ierr)
    call dpotrf('U', rank_A, mat_U, rank_A, ierr)

    out_mat_Inv = out_mat_L

    call dpotri('L', rank_A, out_mat_Inv, rank_A, ierr)
    call dpotri('U', rank_A, mat_U, rank_A, ierr)

    !! Zero out bad entries in upper and lower
    do icol=1,rank_A
        do irow=1,rank_A
            if (irow .lt. icol) then
                out_mat_Inv(irow, icol) = 0
                out_mat_L(irow, icol) = 0
            endif
        enddo
    enddo

    do icol=1,rank_A
        do irow=1,rank_A
            if (irow .ge. icol) then
                mat_U(irow, icol) = 0
            endif
        enddo
    enddo

    out_mat_Inv = out_mat_Inv + mat_U

    return
  end subroutine

  subroutine get_inverse(rank_A, in_mat_A, out_mat_A_Inv)
    implicit none
    integer, intent(in) :: rank_A
    real(8), allocatable, intent(in) :: in_mat_A(:,:)
    real(8), allocatable, intent(inout) :: out_mat_A_Inv(:,:)

    integer, allocatable :: ipiv(:)
    real(8), allocatable :: work(:)

    integer :: ierr
    integer :: lwork

    allocate(ipiv(rank_A))

    if (.not. allocated(out_mat_A_Inv)) then
      allocate(out_mat_A_Inv(rank_A, rank_A))
    endif

    out_mat_A_Inv = 0
    out_mat_A_Inv(1:rank_A, 1:rank_A) = in_mat_A(1:rank_A, 1:rank_A)

    call dgetrf(rank_A, rank_A, out_mat_A_Inv, rank_A, ipiv, ierr)

    lwork = 32 * rank_A
    allocate(work(lwork))

    call dgetri(rank_A, out_mat_A_Inv, rank_A, ipiv, work, lwork, ierr)

    deallocate(ipiv)
    deallocate(work)
  end subroutine

  subroutine get_qr(nrow, ncol, in_mat_A, mat_Q, mat_R)
    implicit none
    integer, intent(in) :: nrow, ncol
    real(8), allocatable, intent(in) :: in_mat_A(:,:)
    real(8), allocatable, intent(inout) :: mat_Q(:,:), mat_R(:,:)

    real(8), allocatable :: work(:), tau(:), temp(:), temp_R(:,:)
    integer :: lwork, ierr, irow, icol

    allocate(tau(min(nrow, ncol)))
    tau = 0
    allocate(temp(1))
    temp = 0

    if (.not. allocated(mat_Q)) then
      allocate(mat_Q(nrow, nrow))
      mat_Q = 0
    endif

    if (.not. allocated(mat_R)) then
      allocate(mat_R(nrow, ncol))
      mat_R = 0
    endif

    mat_R = 0
    mat_R(1:nrow, 1:ncol) = in_mat_A(1:nrow, 1:ncol)

    !! Do a dummy call to find optimal lwork value
    call dgeqrf(nrow, ncol, mat_R, nrow, tau, temp, -1, ierr)

    lwork = int(temp(1))
    allocate(work(lwork))

    !! Form R
    call dgeqrf(nrow, ncol, mat_R, nrow, tau, work, lwork, ierr)

    allocate(temp_R(nrow, max(nrow, ncol)))
    temp_R = 0
    temp_R(1:nrow,1:ncol) = mat_R(1:nrow, 1:ncol)

    !! Get Q back from it
    call dorgqr(nrow, nrow, nrow, temp_R, nrow, tau, work, lwork, ierr)

    mat_Q = 0
    mat_Q(1:nrow, 1:ncol) = temp_R(1:nrow, 1:nrow)

    !! zero out bad entries to make R upper triangular
    do icol=1,ncol
        do irow=1,nrow
            if (irow .gt. icol) then
                mat_R(irow, icol) = 0
            endif
        enddo
    enddo

    deallocate(temp_R)
    deallocate(work)
    deallocate(tau)
    deallocate(temp)
  end subroutine

  subroutine solve_qp(quadr_coeff_G, linear_coeff_a, &
                      n_ineq, ineq_coef_C, ineq_vec_d, &
                      m_eq, eq_coef_A, eq_vec_b, &
                      nvars, sol, ierr)
    !
    implicit none

    !!
    !! Externals
    !!

    ! quadratic coefficient matrix G in
    real(8), allocatable, intent(in) :: quadr_coeff_G(:,:)
    real(8), allocatable, intent(in) :: linear_coeff_a(:)

    integer, intent(in) :: n_ineq
    real(8), allocatable, intent(in) :: ineq_coef_C(:,:)
    real(8), allocatable, intent(in) :: ineq_vec_d(:)

    integer, intent(in) :: m_eq
    real(8), allocatable, intent(in) :: eq_coef_A(:,:)
    real(8), allocatable, intent(in) :: eq_vec_b(:)

    integer, intent(in) :: nvars
    integer, intent(inout) :: ierr

    ! the solution iterate
    real(8), allocatable, intent(inout) :: sol(:)

    !!~~~~~~~~~~ Internals ~~~~~~~~~~!!
    logical :: DONE, FULL_STEP = .false.
    logical :: FIRST_PASS = .true.
    logical :: ADDING_EQ_CONSTRAINTS = .false.
    logical :: BURN_FLAG = .false.

    integer :: irow, icol
    integer :: p,q = 0

    real(8), allocatable :: ineq_prb(:), eq_prb(:)
    real(8), allocatable :: n_p(:)
    real(8), allocatable :: u(:), lagr(:)

    real(8), allocatable :: G_inv(:,:)
    real(8), allocatable :: L_chol(:,:), L_inv(:,:)

    real(8), allocatable :: matB(:,:), matJ(:,:), matQ(:,:), matR(:,:), Rinv(:,:)

    real(8), allocatable :: z_step(:), r_step(:)

    real(8) :: t, t1, t2
    real(8) :: MAX_DOUBLE = huge(t)

    integer :: k, k_dropped, j_dropped
    integer, allocatable :: active_set(:)

    !!~~~~~~~~ Allocations ~~~~~~~~!!
    allocate(L_chol(nvars,nvars))
    allocate(L_inv(nvars,nvars))
    allocate(G_inv(nvars,nvars))

    call do_cholesky_and_inverse(nvars, quadr_coeff_G, L_chol, G_inv)
    call get_inverse(nvars, L_chol, L_inv)

    sol = (-1) * matmul(G_inv, linear_coeff_a)

    allocate(ineq_prb(nvars))
    allocate(n_p(nvars))

    allocate(u(n_ineq + m_eq))
    allocate(lagr(n_ineq + m_eq))

    allocate(z_step(nvars))
    z_step = 0
    allocate(r_step(n_ineq + m_eq))
    r_step = 0

    allocate(matQ(nvars, nvars))
    matQ = 0
    allocate(matJ(nvars, nvars))
    matJ = 0

    allocate(matB(nvars, n_ineq + m_eq))
    matB = 0
    allocate(matR(nvars, n_ineq + m_eq))
    matR = 0
    allocate(Rinv(nvars, n_ineq + m_eq))
    Rinv = 0

    allocate(active_set(n_ineq + m_eq))
    active_set = 0

    DONE = .false.

    if (m_eq .gt. 0) then
      ADDING_EQ_CONSTRAINTS = .true.
    endif

    q = 0

    FIRST_PASS = .true.

    do while (.not. DONE)
      ineq_prb = matmul(transpose(ineq_coef_C), sol) - ineq_vec_d

      if (ADDING_EQ_CONSTRAINTS) then
        eq_prb = matmul(transpose(eq_coef_A), sol) - eq_vec_b
      endif

      if (q .eq. m_eq) then
        ADDING_EQ_CONSTRAINTS = .false.
      endif

      if (any(ineq_prb .lt. 0) .or. ADDING_EQ_CONSTRAINTS) then
        if (ADDING_EQ_CONSTRAINTS) then
          p = m_eq - q
          n_p = eq_coef_A(:,p)
        else
          do icol=1,n_ineq
            if (ineq_prb(icol) .lt. 0) then
              p = icol

              BURN_FLAG = .false.

              !! make sure it's not already in the active set
              do irow=m_eq+1,q
                if (active_set(irow) .eq. p) then
                  BURN_FLAG = .true.
                  exit
                endif
              enddo

              if (BURN_FLAG) then
                cycle
              else
                exit
              endif
            endif
          enddo

          n_p = ineq_coef_C(:,p)
        endif

        if (q .eq. 0) then
          u = 0
        endif

        lagr = 0
        lagr(1:q) = u(1:q)

        FULL_STEP = .false.

        do while (.not. FULL_STEP)
          ineq_prb = matmul(transpose(ineq_coef_C), sol) - ineq_vec_d
          if (ADDING_EQ_CONSTRAINTS) then
            eq_prb = matmul(transpose(eq_coef_A), sol) - eq_vec_b
          endif

          !!###~~~~~~~~ Step 2(a) ~~~~~~~~###
          !!## Calculate step directions
          if (FIRST_PASS) then
            z_step = matmul(G_inv, n_p)
            FIRST_PASS = .false.
          else
            z_step = matmul(matmul(matJ(:, q+1:nvars), transpose(matJ(:, q+1:nvars))), n_p)

            if (q .gt. 0) then
              Rinv = 0
              call get_inverse(q, matR, Rinv)

              r_step = 0
              r_step(1:q) = matmul(matmul(Rinv(1:q,1:q), transpose(matJ(:,1:q))), n_p)
            endif
          endif

          !!###~~~~~~~~ Step 2(b) ~~~~~~~~###
          !! partial step length t1 - max step in dual space
          if ((q .eq. 0) .or. (all(r_step .le. 0)) .or. ADDING_EQ_CONSTRAINTS) then
            t1 = MAX_DOUBLE
          else
            t1 = MAX_DOUBLE
            k_dropped = 0

            do icol=m_eq+1,q
              if ((r_step(icol) .gt. 0) .and. (lagr(icol) / r_step(icol) .lt. t1)) then
                t1 = lagr(icol) / r_step(icol)
                k_dropped = active_set(icol)
                j_dropped = icol
              endif
            enddo
          endif

          !! full step length t2 - min step in primal space
          if (all(z_step .eq. 0)) then
            t2 = MAX_DOUBLE
          else
            if (ADDING_EQ_CONSTRAINTS) then
              t2 = (-1) * eq_prb(p) / dot_product(z_step, n_p)
            else
              t2 = (-1) * ineq_prb(p) / dot_product(z_step, n_p)
            endif
          endif

          t = min(t1, t2)

          !!###~~~~~~~~ Step 2(c) ~~~~~~~~###
          if (t .eq. MAX_DOUBLE) then
            print *, "QP infeasible! stop here!"
            FULL_STEP = .true.
            DONE = .true.
            ierr = 420
            return
          endif

          !! If t2 infinite, then a full step is infeasible
          if (t2 .eq. MAX_DOUBLE) then
            !update lagr
            r_step = (-1) * r_step
            r_step(q+1) = 1
            lagr = lagr + (t * r_step)

            !update active_set
            do icol=j_dropped,n_ineq-1
              active_set(icol) = active_set(icol+1)
            enddo

            q = q - 1

            if (q .eq. 0) then
              ! skip computing the QR, J
              cycle
            endif

            !update QR and J
            do icol=j_dropped,n_ineq-1
              matB(:,icol) = matB(:,icol+1)
            enddo

            call get_qr(nvars, q, matB, matQ, matR)

            matJ = matmul(transpose(L_inv), matQ)

            cycle
          endif

          sol = sol + (t * z_step)

          r_step = (-1) * r_step
          r_step(q+1) = 1
          lagr = lagr + (t * r_step)

          !! took a step in primal space
          if (t .eq. t2) then
            ! update active set
            active_set(q+1) = p
            q = q + 1

            ! update lagr
            u = 0
            u(1:q) = lagr(1:q)

            ! update QR and J
            matB(:,q) = matmul(L_inv, n_p)

            call get_qr(nvars, q, matB, matQ, matR)

            matJ = matmul(transpose(L_inv), matQ)

            FULL_STEP = .true.
            exit
          endif

          !! took a step in dual space
          if (t .eq. t1) then
            !update active_set
            do icol=j_dropped,n_ineq-1
              active_set(icol) = active_set(icol+1)
            enddo

            q = q - 1

            if (q .eq. 0) then
              ! skip QR update
              cycle
            endif

            ! update QR and J
            do icol=j_dropped,n_ineq-1
              matB(:,icol) = matB(:,icol+1)
            enddo

            call get_qr(nvars, q, matB, matQ, matR)

            matJ = matmul(transpose(L_inv), matQ)

            cycle
          endif
        enddo

      else
        DONE = .true.
      endif

    enddo

    deallocate(L_chol)
    deallocate(L_inv)
    deallocate(G_inv)

    deallocate(ineq_prb)
    deallocate(n_p)

    deallocate(u)
    deallocate(lagr)
    deallocate(z_step)
    deallocate(r_step)

    deallocate(matQ)
    deallocate(matJ)
    deallocate(matB)
    deallocate(matR)
    deallocate(Rinv)
    deallocate(active_set)

  end subroutine solve_qp
end module

program test
  use quadprog_ng_redo
  implicit none
  real(8), allocatable :: G(:,:), lin_vec(:), C(:,:), d(:), A(:,:), b(:), sol(:)
  integer :: irow, icol
  integer :: m_eq, n_ineq, ierr

  integer, dimension(2) :: mat_dim

  G = transpose(reshape((/4, -2, -2, 4/),(/2,2/)))

  lin_vec = (/6, 0/)

  print *, "Running Test 00 :: https://tinyurl.com/ux8x4dv"

  allocate(C(2,3))

  C(1,:) = (/1, 0, 1/)
  C(2,:) = (/0, 1, 1/)

  d = (/0, 0, 2/)

  allocate(A(1,1))
  A = 0

  allocate(b(1))
  b = 1

  m_eq = 0
  n_ineq = 3

  allocate(sol(2))

  call solve_qp(G, lin_vec, &
                      n_ineq, C, d, &
                      m_eq, A, b, &
                      2, sol, ierr)

  print *, sol

  deallocate(C)

  print *, "Running Test 01 :: https://tinyurl.com/soytugm"

  allocate(C(2,2))
  C(1,:) = (/1, 0/)
  C(2,:) = (/0, 1/)

  d = (/1, 0/)

  A = reshape((/1,1/), (/2, 1/))

  b = (/6/)

  m_eq = 1
  n_ineq = 2

  call solve_qp(G, lin_vec, &
                n_ineq, C, d, &
                m_eq, A, b, &
                2, sol, ierr)

  print *, sol

end program test


      !----------------------------------------
      ! YLD2004-18P
      !----------------------------------------

      ! calculate principal value of linealy transformed matrix
      SUBROUTINE calc_yld2004_Principal(yldCPrime,yldCDbPrime,
     & yldSPriPrime,yldSPriDbPrime,STRESS)
      INCLUDE 'ABA_PARAM.INC'
      INTEGER i
      DOUBLE PRECISION yldCPrime(6,6),yldCDbPrime(6,6),yldSPriPrime(3),
     & yldSPriDbPrime(3),STRESS(6),yldT(6,6),yldSPrime(6),yldSDbPrime(6)
      yldT(:,:) = 0.0D0
      yldT(1:3,1:3) = -1.0D0
      DO i=1,3
        yldT(i,i) = 2.0D0
        yldT(i+3,i+3) = 3.0D0
      END DO
      yldT(:,:) = yldT(:,:)/3.0D0
      yldSPrime = MATMUL(yldCPrime,MATMUL(yldT,STRESS))
      yldSDbPrime = MATMUL(yldCDbPrime,MATMUL(yldT,STRESS))
      yldSPriPrime(:) = 0.0D0
      yldSPriDbPrime(:) = 0.0D0
      CALL SPRINC(yldSPrime,yldSPriPrime,1,3,3)
      CALL SPRINC(yldSDbPrime,yldSPriDbPrime,1,3,3)
      RETURN
      END SUBROUTINE calc_yld2004_Principal

      ! calculate equivalent stress using Yld2004-18P
      DOUBLE PRECISION FUNCTION calc_yld2004_eqStress(YLDM,yldCPrime,
     & yldCDbPrime,STRESS)
      IMPLICIT NONE
      INTEGER i,j
      DOUBLE PRECISION YLDM,yldCPrime(6,6),yldCDbPrime(6,6),STRESS(6),
     & yldSPriPrime(3),yldSPriDbPrime(3),yldPhi
      yldSPriPrime(:) = 0.0D0
      yldSPriDbPrime(:) = 0.0D0
      CALL calc_yld2004_Principal(yldCPrime,yldCDbPrime,yldSPriPrime,
     & yldSPriDbPrime,STRESS)
      yldPhi = 0.0D0
      DO i=1,3
        DO j=1,3
          yldPhi = yldPhi +
     &     ABS(yldSPriPrime(i) - yldSPriDbPrime(j))**YLDM
        END DO
      END DO
      calc_yld2004_eqStress = (yldPhi/4.0D0)**(1.0D0/YLDM)
      RETURN
      END FUNCTION calc_yld2004_eqStress

      ! calculate first order differential of Yld2004-18P
      SUBROUTINE calc_yld2004_1st_differential(YLDM,yldCPrime,
     & yldCDbPrime,STRESS,firstDiff)
      IMPLICIT NONE
      INTEGER i,j,k
      DOUBLE PRECISION YLDM,yldCPrime(6,6),yldCDbPrime(6,6),STRESS(6),
     & firstDiff(6),DELTAX,yldSPriPrime(3),yldSPriDbPrime(3),yldPhi,
     & subStress(6),subyldPhi,dPhidS(6),eqStress,calc_yld2004_eqStress,
     & dfdPhi
      PARAMETER(DELTAX=1.0D-5)
      yldSPriPrime(:) = 0.0D0
      yldSPriDbPrime(:) = 0.0D0
      CALL calc_yld2004_Principal(yldCPrime,yldCDbPrime,yldSPriPrime,
     & yldSPriDbPrime,STRESS)
      yldPhi = 0.0D0
      DO i=1,3
        DO j=1,3
          yldPhi = yldPhi +
     &     ABS(yldSPriPrime(i) - yldSPriDbPrime(j))**YLDM
        END DO
      END DO
      DO i=1,6
        subStress(:) = STRESS(:)
        subStress(i) = subStress(i) + DELTAX
        yldSPriPrime(:) = 0.0D0
        yldSPriDbPrime(:) = 0.0D0
        CALL calc_yld2004_Principal(yldCPrime,yldCDbPrime,yldSPriPrime,
     &   yldSPriDbPrime,subStress)
        subyldPhi = 0.0D0
        DO j=1,3
          DO k=1,3
            subyldPhi = subyldPhi +
     &       ABS(yldSPriPrime(j) - yldSPriDbPrime(k))**YLDM
          END DO
        END DO
        dPhidS(i) = (subyldPhi - yldPhi)/DELTAX
      END DO
      eqStress = calc_yld2004_eqStress(YLDM,yldCPrime,yldCDbPrime,STRESS)
      dfdPhi = (eqStress**(1-YLDM))/(4.0D0*YLDM)
      firstDiff(:) = dfdPhi*dPhidS(:)
      RETURN
      END SUBROUTINE calc_yld2004_1st_differential

      ! calculate second order differential of Yld2004-18P
      SUBROUTINE calc_yld2004_2nd_differential(YLDM,yldCPrime,
     & yldCDbPrime,STRESS,firstDiff,secondDiff)
      IMPLICIT NONE
      INTEGER i
      DOUBLE PRECISION YLDM,yldCPrime(6,6),yldCDbPrime(6,6),STRESS(6),
     & firstDiff(6),secondDiff(6,6),DELTAX,subStress(6),subfirstDiff(6)
      PARAMETER(DELTAX=1.0D-1)
      DO i=1,6
        subStress(:) = STRESS(:)
        subStress(i) = subStress(i) + DELTAX
        CALL calc_yld2004_1st_differential(YLDM,yldCPrime,yldCDbPrime,
     &   STRESS,subfirstDiff)
        secondDiff(:,i) = (subfirstDiff(:) - firstDiff(:))/DELTAX
      END DO
      RETURN
      END SUBROUTINE calc_yld2004_2nd_differential

      !----------------------------------------
      ! Hill48
      !----------------------------------------

      ! calculate equivalent stress using Hill48
      DOUBLE PRECISION FUNCTION calc_hill48_eqStress(hillParams,STRESS)
      IMPLICIT NONE
      DOUBLE PRECISION hillParams(4),STRESS(6),numerator
      numerator = hillParams(1)*(STRESS(2) - STRESS(3))**2 +
     & hillParams(2)*(STRESS(3)-STRESS(1))**2 +
     & hillParams(3)*(STRESS(1)-STRESS(2))**2 +
     & 2.0D0*hillParams(4)*SUM(STRESS(4:6)**2)
      calc_eqStress = SQRT(1.5D0*numerator/SUM(hillParams(1:3)))
      RETURN
      END FUNCTION calc_hill48_eqStress

      ! calculate differential of plastic potential
      SUBROUTINE calc_hill48_1st_differential(hillParams,STRESS,
     & firstDiff)
      IMPLICIT NONE
      DOUBLE PRECISION hillParams(4),STRESS(6),firstDiff(6),eqStress,
     & calc_hill48_eqStress,multiplier
      eqStress = calc_hill48_eqStress(hillParams,STRESS)
      multiplier = 0.75/(SUM(hillParams(1:3))*eqStress)
      firstDiff(1) = -1.0D0*2*hillParams(2)*(STRESS(3)-STRESS(1))+
     & 2*hillParams(3)*(STRESS(1)-STRESS(2))
      firstDiff(2) = 2*hillParams(1)*(STRESS(2)-STRESS(3))-
     & 2*hillParams(3)*(STRESS(1)-STRESS(2))
      firstDiff(3) = -1.0D0*2*hillParams(1)*(STRESS(2)-STRESS(3))+
     & 2*hillParams(2)*(STRESS(3)-STRESS(1))
      firstDiff(4) = 4*hillParams(4)*STRESS(4)
      firstDiff(5) = 4*hillParams(4)*STRESS(5)
      firstDiff(6) = 4*hillParams(4)*STRESS(6)
      firstDiff(:) = firstDiff(:) * multiplier
      RETURN
      END SUBROUTINE calc_hill48_1st_differential

      ! calculate differential of plastic potential
      SUBROUTINE calc_hill48_2nd_differential(hillParams,STRESS,
     & firstDiff,secondDiff)
      IMPLICIT NONE
      INTEGER i,j
      DOUBLE PRECISION hillParams(4),STRESS(6),firstDiff(6),
     & secondDiff(6,6),eqStress,calc_hill48_eqStress,multiplier
      eqStress = calc_hill48_eqStress(hillParams,STRESS)
      multiplier = 0.75/(SUM(hillParams(1:3))*eqStress)

      secondDiff(:,:) = 0.0D0
      secondDiff(1,1) = 2*hillParams(2) + 2*hillParams(3)
      secondDiff(2,2) = 2*hillParams(1) + 2*hillParams(3)
      secondDiff(3,3) = 2*hillParams(1) + 2*hillParams(2)
      secondDiff(4,4) = 4*hillParams(4)
      secondDiff(5,5) = 4*hillParams(4)
      secondDiff(6,6) = 4*hillParams(4)
      secondDiff(1,2) = -1.0D0*2*hillParams(3)
      secondDiff(1,3) = -1.0D0*2*hillParams(2)
      secondDiff(2,1) = -1.0D0*2*hillParams(3)
      secondDiff(2,3) = -1.0D0*2*hillParams(1)
      secondDiff(3,1) = -1.0D0*2*hillParams(2)
      secondDiff(3,2) = -1.0D0*2*hillParams(1)
      DO i=1,6
        DO j=1,6
          secondDiff(i,j) = multiplier*secondDiff(i,j) -
     &     firstDiff(i)*firstDiff(j)/eqStress
        END DO
      END DO
      RETURN
      END SUBROUTINE calc_hill48_2nd_differential


module lsq
!  LSQ - Interface module for LAPACK QR routines, and a special-purpose
!  subroutine for simple Y versus X linear regressions.
!
!  SYNOPSIS
!    use lsq
!
!  DESCRIPTION
!   The subroutine linfit will calculate the parameters a and b for:
!     -- Linear fitting: y=a·x+b.
!     -- Power fitting: y=a·x^b, using logarithms to linearize.
!   The code chooses which one to apply based on the given entry "model".
!
!  PUBLIC ROUTINES DEFINED
!    linfit - Y versus X linear regression.
!
!  DEPENDENCIES
!    precision - defines KINDs for single- and double-precision floating point.
!
!  REVISION HISTORY
!    10/20/18 - Final version, including both fittings.
!
!  PROGRAMMER
!    Francisco Castillo-Carrasco, fjcasti1@asu.edu
!
  use precision
  implicit none
!
!  Generic interface (for single- or double-precision) for LAPACK
!  QR factorizations SGELS and DGELS.
!
  interface xgels
    subroutine sgels(tr,n,k,nrhs,x,ldx,y,ldy,work,lwork,info)
        import
        character, intent(in):: tr
        integer, intent(in):: n, k, ldx, ldy, nrhs
        integer, intent(inout):: lwork
        real(SP), intent(inout):: x(ldx,k), y(ldy,nrhs), work(lwork)
        integer, intent(out):: info
     end subroutine sgels
!
     subroutine dgels(tr, n, k, nrhs, x, ldx, y, ldy, work, lwork, info)
        import
        character, intent(in):: tr
        integer, intent(in):: n, k, ldx, ldy, nrhs
        integer, intent(inout):: lwork
        real(DP), intent(inout):: x(ldx,k), y(ldy,nrhs), work(lwork)
        integer, intent(out):: info
     end subroutine dgels
  end interface
!
  contains
!----------
  subroutine linfit(model, n, x, y, param, ierr)
      !  ARGUMENTS - model : character variable, expecting "Linear" or "Power", not
      !                      case sensitive.
      !            - n     : dimension of the arrays x and y.
      !            - x     : real 1D array of dimension n, independent variable.
      !            - y     : real 1D array of dimension n, y=f(x).
      !            - param : real 1D array of dimention 2, contains the parameters
      !                      of the fitting.
      !            - ierr  : error flag, 0 if no errors found.
      !
      ! Comments: When using the LAPACK libraries, the code uses it once with
      ! lwork=-1 to find the optimal lwork and a second time to find the with
      ! the optimal lwork to solve the system.
!
  character(*), intent(in) :: model
  integer , intent(in)  :: n
  real(DP), intent(in)  :: x(n)
  real(DP), intent(inout):: y(n)
  real(DP), intent(out) :: param(2)
  integer , intent(out) :: ierr
  integer  :: lwork
  integer  :: info
  real(DP), dimension(:), allocatable :: work
  real(DP) :: A(n,2), B(n)
  lwork=-1

  select case(model(1:1))
  case('L','l')
    A(:,1)=1
    A(:,2)=x
    allocate(work(1))
    call dgels('N', n, 2, 1, A, n, y, n, work, lwork, info)
    lwork=work(1)
    deallocate(work)

    allocate(work(lwork))
    call dgels('N', n, 2, 1, A, n, y, n, work, lwork, info)
    param(1:2)=y(1:2)
    ierr=info
  case('P','p')
    A(:,1)=1
    A(:,2)=log(x)
    B=log(y)
    allocate(work(1))
    call dgels('N', n, 2, 1, A, n, B, n, work, lwork, info)
    lwork=work(1)
    deallocate(work)

    allocate(work(lwork))
    call dgels('N', n, 2, 1, A, n, B, n, work, lwork, info)
    param(1)=exp(B(1))
    param(2)=B(2)
    ierr=info
  case default
    ierr=-1
    print*, "ERROR, MODEL UNKNOWN"
  end select
!
  end subroutine linfit
!-----------------------
end module lsq


PROGRAM laplace_for
implicit none

INTERFACE
    SUBROUTINE for_update1(u, dx2, dy2, nx, ny)
        real(8), intent(inout) :: u(nx,ny)
        real(8), intent(in)    :: dx2, dy2
        integer, intent(in)    :: nx, ny
    END SUBROUTINE
END INTERFACE

integer, parameter :: dp=kind(0.d0)

integer, parameter :: N = 150
integer :: Niter
real(dp) :: u(N, N), t1, t2

read(*,*) Niter

call cpu_time(t1)
u = calc(N, Niter, 0.1_dp, 0.1_dp)
call cpu_time(t2)

open(101,file='data_Looped Fortran (pure)', status='unknown')
write(101,*) u
!print *, t2-t1
!print *, u(2, 2)
!print *, sum(u)
!print *, sum(u**2)
CONTAINS

FUNCTION calc(N, Niter, dx, dy) RESULT(u)
integer, intent(in) :: N, Niter
real(dp), intent(in) :: dx, dy
real(dp) :: u(N,N), dx2, dy2
integer :: i
u = 0
u(1,:) = 1
dx2 = dx**2
dy2 = dy**2
DO i = 1,Niter
    call for_update1(u, dx2, dy2, N, N)
END DO
END FUNCTION

END program


module particle_array_mod
    use, intrinsic :: iso_fortran_env, only : DP => REAL64, error_unit
    implicit none

    real(kind=DP), parameter :: e_mass = 0.510999_DP, p_mass = 938.272_DP
    integer, parameter :: e_charge = -1, p_charge = +1

    type :: particles_t(nr_particles)
        integer, len :: nr_particles
        real(kind=DP), dimension(nr_particles) :: x, y, z, mass
        integer, dimension(nr_particles) :: charge
    end type particles_t

    type :: coordinates_t
        real(kind=DP) :: x, y, z
    end type coordinates_t

contains

    subroutine init_particles(particles)
        implicit none
        type(particles_t(*)) :: particles
        real, dimension(:), allocatable :: r
        integer :: status

        call random_number(particles%x)
        call rescale(particles%x)
        call random_number(particles%y)
        call rescale(particles%y)
        call random_number(particles%x)
        call rescale(particles%x)
        allocate(r(size(particles%x)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'can not allocate array'
            stop 1
        end if
        call random_number(r)
        where (r < 0.5)
            particles%mass = p_mass
            particles%charge = p_charge
        elsewhere
            particles%mass = e_mass
            particles%charge = e_charge
        end where
        deallocate(r)

    contains

        pure subroutine rescale(coords)
            implicit none
            real(kind=DP), dimension(:), intent(inout) :: coords
            coords = 2.0_DP*coords - 1.0_DP
        end subroutine rescale

    end subroutine init_particles

    function compute_center_of_mass(particles) result(coordinates)
        implicit none
        type(particles_t(*)), intent(in) :: particles
        type(coordinates_t) :: coordinates
        real(kind=DP) :: total_mass

        coordinates%x = sum(particles%x)
        coordinates%y = sum(particles%y)
        coordinates%z = sum(particles%z)
        total_mass = sum(particles%mass)
        coordinates%x = coordinates%x/total_mass
        coordinates%y = coordinates%y/total_mass
        coordinates%z = coordinates%z/total_mass
    end function compute_center_of_mass

end module particle_array_mod


program test_tensor_rot
!  Test that my own implementation of CIJ_rotate3() is correct
!  It is, but it's much slower than Mainprice's

   use anisotropy_ajn

   implicit none

   integer,parameter :: rs=8
   real,parameter :: pi = 3.141592653589793238462643_rs
   real(rs) :: T(3,3,3,3), Tr(3,3,3,3), CIJ(6,6), CIJr(6,6), CIJ1(6,6)
   real(rs) :: alp,bet,gam
   integer  :: i,j,k,l,a,b,c,d, n
   integer  :: seconds0=0, seconds1=0, rate
   real(rs),dimension(3,3) :: R,Ra,Rb,Rc,g   ! Rotation matrices
   integer :: nrot=5000
   character(len=80) :: arg

   if (command_argument_count() == 1) then
      call get_command_argument(1,arg)
      read(arg,*) nrot
   endif

!************************************************
!  Rotate tensor the explicit way

!  Make a symmetrical matrix
   do i=1,6
      do j=1,6
         CIJ(i,j) = real(i*j) !*1.d9
      enddo
   enddo

!  Start clock
   seconds0 = 0
   call system_clock(seconds0,rate)

!  Fill in T from C
   T = Cij2cijkl(CIJ)

!  Rotation angles
   alp = 25._rs * pi / 180._rs
   bet = 0. !30._rs * pi / 180._rs
   gam = 0. !45._rs * pi / 180._rs

!  Create rotation matrices
   Ra(1,1) =  1.     ; Ra(1,2) =  0.     ; Ra(1,3) =  0.
   Ra(2,1) =  0.     ; Ra(2,2) =  cos(alp) ; Ra(2,3) =  sin(alp)
   Ra(3,1) =  0.     ; Ra(3,2) = -sin(alp) ; Ra(3,3) =  cos(alp)

   Rb(1,1) =  cos(bet) ; Rb(1,2) =  0.     ; Rb(1,3) = -sin(bet)
   Rb(2,1) =  0.     ; Rb(2,2) =  1.     ; Rb(2,3) =  0.
   Rb(3,1) =  sin(bet) ; Rb(3,2) =  0.     ; Rb(3,3) =  cos(bet)

   Rc(1,1) =  cos(gam) ; Rc(1,2) =  sin(gam) ; Rc(1,3) =  0.
   Rc(2,1) = -sin(gam) ; Rc(2,2) =  cos(gam) ; Rc(2,3) =  0.
   Rc(3,1) =  0.     ; Rc(3,2) =  0.     ; Rc(3,3) =  1.

   R = matmul(Rb,Ra)
   g = matmul(Rc,R)

!  Rotate tensor 500 times:
   do n=1,nrot
   Tr = 0._rs
   do l=1,3
      do k=1,3
         do j=1,3
            do i=1,3
               do d=1,3
                  do c=1,3
                     do b=1,3
                        do a=1,3
                           Tr(i,j,k,l) = &
                              Tr(i,j,k,l) + g(i,a)*g(j,b)*g(k,c)*g(l,d)*T(a,b,c,d)
                        enddo
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo
   enddo
   enddo

!  Stop clock
   call system_clock(seconds1,rate)

!  Show results
   CIJr = cijkl2Cij(Tr)
   CIJ1 = CIJr
   write(*,'(a,f0.4,a)') 'Output from inbuilt rotation took ', &
                  (seconds1-seconds0)/real(rate),' seconds:'
   write(*,'(6f12.4)') CIJr
   write(*,*)

!************************************************
!  Call CIJ_rot3

!  Make a symmetrical matrix
   do i=1,6
      do j=1,6
         CIJ(i,j) = real(i*j) !*1.d9
      enddo
   enddo

!  Compare to CIJ_rot3
   call system_clock(seconds0,rate)
   do n=1,nrot
      call CIJ_rot3(CIJ,alp*180./pi,bet*180./pi,gam*180./pi,CIJr)
   enddo
   call system_clock(seconds1,rate)
   write(*,'(a,f6.4,a)') 'Output from CIJ_rot3 took: ', &
                  (seconds1-seconds0)/real(rate),' seconds:'
   write(*,'(6f12.4)') CIJr
   write(*,*)

   write(*,'(a)') 'Percentage error:'
   write(*,'(6f7.0)') 100._rs*(CIJ1-CIJr)/CIJr

end program


      SUBROUTINE ROT123(KAXIS1,ANG1,KAXIS2,ANG2,KAXIS3,ANG3,RMAT,LUERR,
     1                  IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  ROT123 COMPUTES A MATRIX, RMAT, THAT REFLECTS A SEQUENCE OF 0, 1, 2,
C  OR 3 ROTATIONS OF A COORDINATE SYSTEM ABOUT ITS OWN AXES. RMAT
C  TRANSFORMS COORDINATES FROM THE PRE-ROTATION COORDINATE SYSTEM TO
C  THOSE IN THE POST-ROTATION ONE(SEE THE RMAT ENTRY IN THE CALLING
C  SEQUENCE DESCRIPTION BELOW).
C
C  AN OBJECT HAS DIFFERENT COORDINATE VALUES IN DIFFERENT SYSTEMS. RMAT
C  IS USED TO TRANSFORM COORDINATE VALUES FROM ONE SYSTEM TO ANOTHER.
C  THE OBJECT ITSELF DOES NOT MOVE.
C
C  THE TERM ROTATION REFERS TO ROTATIONS THAT THE STARTING COORDINATE
C  SYSTEM WOULD UNDERGO IF ITS X/Y/Z AXES WERE TO BE ALIGNED WITH THOSE
C  OF THE FINAL SYSTEM.
C
C  EXAMPLES OF USES:
C
C     RMAT TRANSFORMS THE COORDINATES OF A STAR'S POSITION FROM MEAN
C     OF 1950.0 EQUATORIAL COORDINATE SYSTEM TO MEAN OF 1950.0 ECLIPTIC
C     COORDINATE SYSTEM. THE ROTATION IS ABOUT THE 1950.0'S X-AXIS. THE
C     STAR'S POSITION DOES NOT CHANGE, BUT THE COORDINATES DESCRIBING IT
C     CHANGE WHEN THE COORDINATE SYSTEM IS CHANGED.
C
C     RMAT TRANSFORMS THE COORDINATES OF A STAR'S POSITION FROM
C     S/C-FIXED COORDINATES BEFORE A S/C ROLL, PITCH, YAW MANEUVER TO
C     THE S/C FIXED COORDINATES AFTER THE MANEUVER. THE STAR'S POSITION
C     DOES NOT CHANGE, BUT THE S/C-FIXED COORDINATES DESCRIBING IT
C     CHANGE WHEN THE S/C AXES CHANGE DIRECTION.
C
C     AT A GIVEN INSTANT, RMAT TRANSFORMS THE COORDINATES OF AN EARTH
C     SURFACE POSITION FROM EARTH-FIXED TO INERTIAL COORDINATES. THE
C     ROTATION IS ABOUT THE EARTH Z-AXIS. THE POSITION DOES NOT MOVE,
C     BUT THE X,Y,Z COORDINATES DESCRIBING IT CHANGE WHEN THE
C     COORDINATE SYSTEM IS CHANGED.
C
C  IF ROT1, ROT2, ROT3 ARE THE ROTATION MATRICES FOR THE FIRST, SECOND,
C  AND THIRD ROTATIONS, RESPECTIVELY, THEN
C
C     RMAT = ROT3 * ROT2 * ROT1
C
C  KAXISx ASSIGNMENTS:
C
C             KAXISx = 0, NO ROTATION. EQUIVALENT TO 0.0 ROTATION ANGLE.
C             KAXISx = 1, ROLL ABOUT X-AXIS.
C                         ANGx POSITIVE FROM +Y TOWARD +Z.
C             KAXISx = 2, PITCH ABOUT Y-AXIS.
C                         ANGx POSITIVE FROM +Z TOWARD +X.
C             KAXISx = 3, YAW ABOUT Z-AXIS.
C                         ANGx POSITIVE FROM +X TOWARD +Y.
C             KAXISx = OTHERWISE, ERROR CONDITION.
C
C             EXAMPLE:  KAXIS1=3, KAXIS2=1, KAXIS3=2 MEANS THAT THE
C                       FIRST ROTATION IS ABOUT THE Z-AXIS, THE SECOND
C                       IS ABOUT THE X-AXIS, AND THE THIRD IS ABOUT THE
C                       Y-AXIS.
C
C      KAXISx VALUES MAY REPEAT THEMSELVES. EXAMPLES OF VALID INPUTS:
C
C              KAXIS1=2, KAXIS2=3, KAXIS3=2
C              KAXIS1=3, KAXIS2=3, KAXIS3=3
C              KAXIS1=0, KAXIS2=1, KAXIS3=0
C              KAXIS1=2, KAXIS2=2, KAXIS3=2
C
C  VARIABLE  DIM  TYPE  I/O  DESCRIPTION
C  --------  ---  ----  ---  -----------
C
C  KAXIS1     1    I*4   I   AXIS NUMBER ABOUT WHICH THE FIRST ROTATION
C                            WILL OCCUR.
C
C  ANG1       1    R*8   I   ROTATION ANGLE CORRESPONDING TO KAXIS1.
C                            IN RADIANS. IGNORED IF KAXIS1 = 0.
C
C  KAXIS2     1    I*4   I   AXIS NUMBER ABOUT WHICH THE SECOND ROTATION
C                            WILL OCCUR. THE SECOND AXIS MAY HAVE BEEN
C                            REPOSITIONED BY THE FIRST ROTATION.
C
C  ANG2       1    R*8   I   ROTATION ANGLE CORRESPONDING TO KAXIS2.
C                            IN RADIANS. IGNORED IF KAXIS2 = 0.
C
C  KAXIS3     1    I*4   I   AXIS NUMBER ABOUT WHICH THE THIRD ROTATION
C                            WILL OCCUR. THE THIRD AXIS MAY HAVE BEEN
C                            REPOSITIONED BY THE FIRST TWO ROTATIONS.
C
C  ANG3       1    R*8   I   ROTATION ANGLE CORRESPONDING TO KAXIS3.
C                            IN RADIANS. IGNORED IF KAXIS3 = 0.
C
C  RMAT      3,3   R*8   O   ROTATION MATRIX THAT TRANSFORMS COORDINATES
C                            FROM ONE SYSTEM TO ANOTHER.
C
C                            A VECTOR WHICH DOES NOT MOVE WITH THE
C                            ROTATIONS WILL HAVE COORDINATES
C                            [V1(1),V1(2),V1(3)] BEFORE THE ROTATION
C                            AND COORDINATES [V2(1),V2(2),V2(3)] AFTER
C                            THE ROTATION. THE RELATIONSHIP IS:
C
C                               V2(I) = RMAT(I,J) * V1(J), SUMMING ON J.
C
C  LUERR      1    I*4   I   FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C                            PROGRAM CHECKS FOR INVALID KAXIS VALUES.
C                            LUERR = 0 MEANS NO ERROR MESSAGES POSSIBLE.
C
C  IERR       1    I*4   O   ERROR RETURN FLAG.
C                            = 0, NO ERROR.   =1, ERROR.
C
C***********************************************************************
C
C  BY C PETRUZZO, 2/83.
C       MODIFIED..... 4/85. CJP. COMMENT MODS, NO CODE MODS.
C
C***********************************************************************
C
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      REAL*8 RMAT(3,3)
      REAL*8 AIDENT(3,3)/1.D0,3*0.D0,1.D0,3*0.D0,1.D0/
      REAL*8 ROT1AX(3,3),RSOFAR(3,3)
      INTEGER KAXIS(3),NERR/0/
      REAL*8 ANGVALS(3)
C
      IERR=0
C
C  LOAD KAXIS AND ANGVALS ARRAYS.
      KAXIS(1) = KAXIS1
      ANGVALS(1) = ANG1
      KAXIS(2) = KAXIS2
      ANGVALS(2) = ANG2
      KAXIS(3) = KAXIS3
      ANGVALS(3) = ANG3
C
C  SET RSOFAR TO THE IDENTITY MATRIX.
      CALL MTXEQL(AIDENT,RSOFAR,3,3)
C
C  ROTATE ABOUT EACH AXIS. MAY BE REPETITIONS.
      DO 100 IAX=1,3
      KAXNOW=KAXIS(IAX)
      IF(KAXNOW.EQ.0) GO TO 100
      ANGNOW=ANGVALS(IAX)
      IF(ANGNOW.EQ.0.D0) GO TO 100
C
C  ERROR CHECK.
      IF(KAXNOW.LT.0 .OR. KAXNOW.GT.3) THEN
        CALL MESAGE(1,NERR,20,0,1,1,LUERR,
     1     'ERROR IN ROT123. INVALID AXIS FLAG. ZERO ROTATION.')
        CALL MTXEQL(AIDENT,RSOFAR,3,3)
        IERR=1
        GO TO 110
        END IF
C
C  INITIALIZE FOR THE CURRENT AXIS.
      COSANG = DCOS(ANGNOW)
      SINANG = DSIN(ANGNOW)
      CALL MTXSETR8(ROT1AX,0.D0,3,3)   ! ZERO IT OUT.
C
      IF(KAXNOW.EQ.1) THEN
C       ROTATING ABOUT X-AXIS.
        ROT1AX(1,1)=1.D0
        ROT1AX(2,2)=COSANG
        ROT1AX(3,3)=COSANG
        ROT1AX(2,3)=SINANG
        ROT1AX(3,2)=-SINANG
        GO TO 150
        END IF
C
      IF(KAXNOW.EQ.2) THEN
C       ROTATING ABOUT Y-AXIS.
        ROT1AX(2,2)=1.D0
        ROT1AX(1,1)=COSANG
        ROT1AX(3,3)=COSANG
        ROT1AX(1,3)=-SINANG
        ROT1AX(3,1)=SINANG
        GO TO 150
        END IF
C
      IF(KAXNOW.EQ.3) THEN
C       ROTATING ABOUT Z-AXIS.
        ROT1AX(3,3)=1.D0
        ROT1AX(1,1)=COSANG
        ROT1AX(2,2)=COSANG
        ROT1AX(1,2)=SINANG
        ROT1AX(2,1)=-SINANG
        GO TO 150
        END IF
C
  150 CONTINUE
C
C  ROTATE(MULTIPLY) THE CURRENT RSOFAR ROTATION MATRIX BY THE MATRIX
C  JUST COMPUTED, AND REPLACE RSOFAR WITH THE PRODUCT.
      CALL MTXMUL33(1,ROT1AX,RSOFAR,RSOFAR)
C
  100 CONTINUE
  110 CONTINUE
C
C  NOW LOAD RSOFAR INTO RMAT FOR RETURN TO CALLER.
      CALL MTXEQL(RSOFAR,RMAT,3,3)
C
      RETURN
      END


module mod_rotation
  use mod_prec
  implicit none
 ! A simple derived type for rotations, routines for computing
 ! rotations that introduce zeros, and routines for applying the
 ! rotations to matrices and vectors.
  private

  public :: d_rotation, z_rotation

  public :: lgivens, d_lgivens, z_lgivens, lgivens2, d_lgivens2, z_lgivens2, &
       rgivens, d_rgivens, z_rgivens, rgivens2, d_rgivens2, z_rgivens2

  public :: trp_rot, d_trp_rot, z_trp_rot

  public :: f_rotation_times_general, f_d_rotation_times_general, &
       f_z_rotation_times_general, f_d_rotation_times_general_v, &
       f_z_rotation_times_general_v

  public :: f_general_times_rotation, f_d_general_times_rotation, &
       f_z_general_times_rotation, f_d_general_times_rotation_v, &
       f_z_general_times_rotation_v

  public :: rotation_times_general, d_rotation_times_general, z_rotation_times_general, &
       d_rotation_times_general_v, z_rotation_times_general_v

  public :: general_times_rotation, d_general_times_rotation, z_general_times_rotation, &
       d_general_times_rotation_v, z_general_times_rotation_v

  type d_rotation
     real(kind=dp) :: cosine
     real(kind=dp) :: sine
  end type d_rotation

  type z_rotation
     real(kind=dp) :: cosine
     complex(kind=dp) :: sine
  end type z_rotation

  interface lgivens
     module procedure d_lgivens, z_lgivens
  end interface lgivens

  interface lgivens2
     module procedure d_lgivens2, z_lgivens2
  end interface lgivens2

  interface rgivens
     module procedure d_rgivens, z_rgivens
  end interface rgivens

  interface rgivens2
     module procedure d_rgivens2, z_rgivens2
  end interface rgivens2

  interface trp_rot
     module procedure d_trp_rot, z_trp_rot
  end interface trp_rot

  interface f_rotation_times_general
     module procedure f_d_rotation_times_general, f_z_rotation_times_general, &
          f_d_rotation_times_general_v, f_z_rotation_times_general_v
  end interface f_rotation_times_general

  interface f_general_times_rotation
     module procedure f_d_general_times_rotation, f_z_general_times_rotation, &
          f_d_general_times_rotation_v, f_z_general_times_rotation_v
  end interface f_general_times_rotation

  interface rotation_times_general
     module procedure d_rotation_times_general, z_rotation_times_general, &
          d_rotation_times_general_v, z_rotation_times_general_v
  end interface rotation_times_general

  interface general_times_rotation
     module procedure d_general_times_rotation, z_general_times_rotation, &
          d_general_times_rotation_v, z_general_times_rotation_v
  end interface general_times_rotation

contains

  ! compute a rotation r=[c,-s;s,c] such that r^T * [x;y]=[z;0]
  type(d_rotation) function d_lgivens(x,y) result(r)
    real(kind=dp), intent(in) :: x, y
    real(kind=dp) :: w, z, x0, y0
    z=max(abs(x), abs(y))
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=0.0_dp
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc
       end do
       w=1/sqrt(x0*x0+y0*y0)
       r%cosine=x0*w
       r%sine=y0*w
    end if
  end function d_lgivens

  ! rotation such that r=[c,-conj(s); s, c] and r^H * [x;y] = [z;0]
  type(z_rotation) function z_lgivens(x,y) result(r)
    complex(kind=dp), intent(in) :: x, y
    complex(kind=dp) :: x0, y0
    real(kind=dp) :: w, z, xabs, yabs
    xabs=abs(x); yabs=abs(y)
    z=max(xabs, yabs)
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=(0.0_dp, 0.0_dp)
    else if (xabs == 0.0_dp) then
       r%cosine=0.0_dp
       r%sine=(1.0_dp,0.0_dp)
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv;
          xabs=xabs*scinv; yabs=yabs*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc;
          xabs=xabs*sc; yabs=yabs*sc
       end do
       w=1/sqrt(xabs*xabs+yabs*yabs)
       r%cosine=xabs*w
       r%sine=y0*w*(conjg(x0)/xabs)
    end if
  end function z_lgivens

  ! compute a rotation r=[c,-s;s,c] such that r^T * [x;y]=[0;z]
  type(d_rotation) function d_lgivens2(x,y) result(r)
    real(kind=dp), intent(in) :: x, y
    real(kind=dp) :: w, z, x0, y0
    z=max(abs(x), abs(y))
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=0.0_dp
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc
       end do
       w=1/sqrt(x0*x0+y0*y0)
       r%cosine=y0*w
       r%sine=-x0*w
    end if
  end function d_lgivens2

  ! rotation such that r=[c,-conj(s); s, c] and r^H * [x;y] = [0;z]
  type(z_rotation) function z_lgivens2(x,y) result(r)
    complex(kind=dp), intent(in) :: x, y
    complex(kind=dp) :: x0, y0
    real(kind=dp) :: w, z, xabs, yabs
    yabs=abs(y)
    xabs=abs(x)
    z=max(yabs, xabs)
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=(0.0_dp,0.0_dp)
    else if (yabs == 0.0_dp) then
       r%cosine=0.0_dp
       r%sine=(1.0_dp,0.0_dp)
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv;
          xabs=xabs*scinv; yabs=yabs*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc;
          xabs=xabs*sc; yabs=yabs*sc
       end do
       w=1/sqrt(xabs*xabs+yabs*yabs)
       r%cosine=yabs*w
       r%sine=-conjg(x0)*w*(y0/yabs)
    end if
  end function z_lgivens2

  ! rotations r=[c,-s; s, c] such that [x,y] * r = [z, 0]
  type(d_rotation) function d_rgivens(x,y) result(r)
    real(kind=dp), intent(in) :: x, y
    real(kind=dp) :: w, z, x0, y0
    z=max(abs(x), abs(y))
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=0.0_dp
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc
       end do
       w=1/sqrt(x0*x0+y0*y0)
       r%cosine=x0*w
       r%sine=y0*w
    end if
  end function d_rgivens

  ! rotations r=[c,-conj(s); s, c] such that [x,y] * r = [z, 0]
  type(z_rotation) function z_rgivens(x,y) result(r)
    complex(kind=dp), intent(in) :: x, y
    complex(kind=dp) :: x0, y0
    real(kind=dp) :: w, z, xabs, yabs
    xabs=abs(x)
    yabs=abs(y)
    z=max(xabs,yabs)
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=(0.0_dp,0.0_dp)
    else if (xabs == 0.0_dp) then
       r%cosine=0.0_dp
       r%sine=(1.0_dp,0.0_dp)
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv;
          xabs=xabs*scinv; yabs=yabs*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc;
          xabs=xabs*sc; yabs=yabs*sc
       end do
       w=1/sqrt(xabs*xabs+yabs*yabs)
       r%cosine=xabs*w
       r%sine=conjg(y0)*w*(x0/xabs)
    end if
  end function z_rgivens

  ! rotations r=[c,-s; s, c] such that [x,y] * r = [0, z]
  type(d_rotation) function d_rgivens2(x,y) result(r)
    real(kind=dp), intent(in) :: x, y
    real(kind=dp) :: w, z, x0, y0
    z=max(abs(x), abs(y))
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=0.0_dp
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc
       end do
       w=1/sqrt(x0*x0+y0*y0)
       r%cosine=y0*w
       r%sine=-x0*w
    end if
  end function d_rgivens2

  ! rotations r=[c,-conj(s); s, c] such that [x,y] * r = [0, z]
  type(z_rotation) function z_rgivens2(x,y) result(r)
    complex(kind=dp), intent(in) :: x, y
    complex(kind=dp) :: x0, y0
    real(kind=dp) :: w, z, yabs, xabs
    xabs=abs(x)
    yabs=abs(y)
    z=max(xabs, yabs)
    if (z == 0.0_dp) then
       r%cosine=1.0_dp
       r%sine=(0.0_dp,0.0_dp)
    else if (yabs == 0.0_dp) then
       r%cosine=0.0_dp
       r%sine=(1.0_dp,0.0_dp)
    else
       x0=x; y0=y
       do while (z > sc)
          z=z*scinv; x0=x0*scinv; y0=y0*scinv;
          xabs=xabs*scinv; yabs=yabs*scinv
       end do
       do while (z < scinv)
          z=z*sc; x0=x0*sc; y0=y0*sc;
          xabs=xabs*sc; yabs=yabs*sc
       end do
       w=1/sqrt(xabs*xabs+yabs*yabs)
       r%cosine=yabs*w
       r%sine=-x0 * w* conjg(y0)/yabs
    end if
  end function z_rgivens2

  ! r*a with r=[c,-s;s,c]
  subroutine f_d_rotation_times_general(c,s,a,j1,j2)
    real(kind=dp), dimension(:,:), intent(inout) :: a
    real(kind=dp), intent(in) :: c,s
    integer(kind=int32), intent(in) :: j1, j2
    !
    integer(kind=int32) :: n, k
    real(kind=dp) :: tmp
    n=size(a,2)
    do k=1,n
       tmp=a(j1, k)
       a(j1,k)=c*tmp-s*a(j2,k)
       a(j2,k)=s*tmp+c*a(j2,k)
    end do
  end subroutine f_d_rotation_times_general

  ! r*a with r=[c,-s;s,c]
  subroutine d_rotation_times_general(r,a,j1,j2)
    real(kind=dp), dimension(:,:), intent(inout) :: a
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j1, j2
    !
    integer(kind=int32) :: n, k
    real(kind=dp) :: c, s, tmp
    c=r%cosine
    s=r%sine
    n=size(a,2)
    do k=1,n
       tmp=a(j1, k)
       a(j1,k)=c*tmp-s*a(j2,k)
       a(j2,k)=s*tmp+c*a(j2,k)
    end do
  end subroutine d_rotation_times_general

  subroutine f_d_rotation_times_general_v(c,s,a,j1,j2)
    real(kind=dp), dimension(:), intent(inout) :: a
    real(kind=dp), intent(in) :: c,s
    integer(kind=int32), intent(in) :: j1, j2
    !
    real(kind=dp) :: tmp
    tmp=a(j1)
    a(j1)=c*tmp-s*a(j2)
    a(j2)=s*tmp+c*a(j2)
  end subroutine f_d_rotation_times_general_v

  subroutine d_rotation_times_general_v(r,a,j1,j2)
    real(kind=dp), dimension(:), intent(inout) :: a
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j1, j2
    !
    real(kind=dp) :: c, s, tmp
    c=r%cosine
    s=r%sine
    tmp=a(j1)
    a(j1)=c*tmp-s*a(j2)
    a(j2)=s*tmp+c*a(j2)
  end subroutine d_rotation_times_general_v

  ! r*a with r=[c,-conj(s);s,c]
  subroutine f_z_rotation_times_general(c,s,a,j1,j2)
    complex(kind=dp), dimension(:,:), intent(inout) :: a
    real(kind=dp), intent(in) :: c
    complex(kind=dp), intent(in) :: s
    integer(kind=int32), intent(in) :: j1, j2
    !
    integer(kind=int32) :: n, k
    complex(kind=dp) :: tmp
    n=size(a,2)
    do k=1,n
       tmp=a(j1, k)
       a(j1,k)=c*tmp-conjg(s)*a(j2,k)
       a(j2,k)=s*tmp+c*a(j2,k)
    end do
  end subroutine f_z_rotation_times_general

  ! r*a with r=[c,-conj(s);s,c]
  subroutine z_rotation_times_general(r,a,j1,j2)
    complex(kind=dp), dimension(:,:), intent(inout) :: a
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j1, j2
    !
    integer(kind=int32) :: n, k
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    c=r%cosine
    s=r%sine
    n=size(a,2)
    do k=1,n
       tmp=a(j1, k)
       a(j1,k)=c*tmp-conjg(s)*a(j2,k)
       a(j2,k)=s*tmp+c*a(j2,k)
    end do
  end subroutine z_rotation_times_general

  subroutine f_z_rotation_times_general_v(c,s,a,j1,j2)
    complex(kind=dp), dimension(:), intent(inout) :: a
    complex(kind=dp), intent(in) :: s
    real(kind=dp), intent(in) :: c
    integer(kind=int32), intent(in) :: j1, j2
    !
    complex(kind=dp) :: tmp
    tmp=a(j1)
    a(j1)=c*tmp-conjg(s)*a(j2)
    a(j2)=s*tmp+c*a(j2)
  end subroutine f_z_rotation_times_general_v

  subroutine z_rotation_times_general_v(r,a,j1,j2)
    complex(kind=dp), dimension(:), intent(inout) :: a
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j1, j2
    !
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    c=r%cosine
    s=r%sine
    tmp=a(j1)
    a(j1)=c*tmp-conjg(s)*a(j2)
    a(j2)=s*tmp+c*a(j2)
  end subroutine z_rotation_times_general_v

  ! a*r with r=[c,-s;s,c]
  subroutine f_d_general_times_rotation(a,c,s,k1,k2)
    real(kind=dp), dimension(:,:), intent(inout) :: a
    real(kind=dp), intent(in) :: c,s
    integer(kind=int32), intent(in) :: k1, k2
    !
    integer(kind=int32) :: m, j
    real(kind=dp) :: tmp
    m=size(a,1)
    do j=1,m
       tmp=a(j,k1)
       a(j,k1)=c*tmp+s*a(j,k2)
       a(j,k2)=-s*tmp+c*a(j,k2)
    end do
  end subroutine f_d_general_times_rotation

  ! a*r with r=[c,-s;s,c]
  subroutine d_general_times_rotation(a,r,k1,k2)
    real(kind=dp), dimension(:,:), intent(inout) :: a
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k1, k2
    !
    integer(kind=int32) :: m, j
    real(kind=dp) :: c, s, tmp
    c=r%cosine
    s=r%sine
    m=size(a,1)
    do j=1,m
       tmp=a(j,k1)
       a(j,k1)=c*tmp+s*a(j,k2)
       a(j,k2)=-s*tmp+c*a(j,k2)
    end do
  end subroutine d_general_times_rotation

  subroutine f_d_general_times_rotation_v(a,c,s,k1,k2)
    real(kind=dp), dimension(:), intent(inout) :: a
    real(kind=dp), intent(in) :: c,s
    integer(kind=int32), intent(in) :: k1, k2
    !
    real(kind=dp) :: tmp
    tmp=a(k1)
    a(k1)=c*tmp+s*a(k2)
    a(k2)=-s*tmp+c*a(k2)
  end subroutine f_d_general_times_rotation_v

  subroutine d_general_times_rotation_v(a,r,k1,k2)
    real(kind=dp), dimension(:), intent(inout) :: a
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k1, k2
    !
    real(kind=dp) :: c, s, tmp
    c=r%cosine
    s=r%sine
    tmp=a(k1)
    a(k1)=c*tmp+s*a(k2)
    a(k2)=-s*tmp+c*a(k2)
  end subroutine d_general_times_rotation_v

  ! a*r with r=[c,-conj(s);s,c]
  subroutine f_z_general_times_rotation(a,c,s,k1,k2)
    complex(kind=dp), dimension(:,:), intent(inout) :: a
    real(kind=dp), intent(in) :: c
    complex(kind=dp), intent(in) :: s
    integer(kind=int32), intent(in) :: k1, k2
    !
    integer(kind=int32) :: m, j
    complex(kind=dp) :: tmp
    m=size(a,1)
    do j=1,m
       tmp=a(j,k1)
       a(j,k1)=c*tmp+s*a(j,k2)
       a(j,k2)=-conjg(s)*tmp+c*a(j,k2)
    end do
  end subroutine f_z_general_times_rotation

  ! a*r with r=[c,-conj(s);s,c]
  subroutine z_general_times_rotation(a,r,k1,k2)
    complex(kind=dp), dimension(:,:), intent(inout) :: a
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k1, k2
    !
    integer(kind=int32) :: m, j
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    c=r%cosine
    s=r%sine
    m=size(a,1)
    do j=1,m
       tmp=a(j,k1)
       a(j,k1)=c*tmp+s*a(j,k2)
       a(j,k2)=-conjg(s)*tmp+c*a(j,k2)
    end do
  end subroutine z_general_times_rotation

  subroutine f_z_general_times_rotation_v(a,c,s,k1,k2)
    complex(kind=dp), dimension(:), intent(inout) :: a
    complex(kind=dp), intent(in) :: s
    real(kind=dp), intent(in) :: c
    integer(kind=int32), intent(in) :: k1, k2
    !
    complex(kind=dp) :: tmp
    tmp=a(k1)
    a(k1)=c*tmp+s*a(k2)
    a(k2)=-conjg(s)*tmp+c*a(k2)
  end subroutine f_z_general_times_rotation_v

  subroutine z_general_times_rotation_v(a,r,k1,k2)
    complex(kind=dp), dimension(:), intent(inout) :: a
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k1, k2
    !
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    c=r%cosine
    s=r%sine
    tmp=a(k1)
    a(k1)=c*tmp+s*a(k2)
    a(k2)=-conjg(s)*tmp+c*a(k2)
  end subroutine z_general_times_rotation_v

  type(d_rotation) function d_trp_rot(r) result(tr)
    type(d_rotation), intent(in) :: r
    tr%cosine=r%cosine
    tr%sine=-r%sine
  end function d_trp_rot

  type(z_rotation) function z_trp_rot(r) result(tr)
    type(z_rotation), intent(in) :: r
    tr%cosine=r%cosine
    tr%sine=-r%sine
  end function z_trp_rot

end module mod_rotation


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   hompdf.f90 - homogenized pdf stationary points
!----------------------------------------------------------------------
!----------------------------------------------------------------------

subroutine ik01a ( x, bi0, bi1 )

! Removed di0, di1 and all k
!*****************************************************************************80
!
!! IK01A compute Bessel function I0(x), I1(x), K0(x), and K1(x).
!
!  Discussion:
!
!    This procedure computes modified Bessel functions I0(x), I1(x),
!
!  Licensing:
!
!    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!    they give permission to incorporate this routine into a user program
!    provided that the copyright is acknowledged. Adapted by Doug Addy to remove
!    superfluous functionality
!
!  Modified:
!
!    01 July 2017
!
!  Author:
!
!    Shanjie Zhang, Jianming Jin
!
!  Reference:
!
!    Shanjie Zhang, Jianming Jin,
!    Computation of Special Functions,
!    Wiley, 1996,
!    ISBN: 0-471-11963-6,
!    LC: QA351.C45.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X, the argument.
!
!    Output, real ( kind = 8 ) BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1, the
!    values of I0(x), I0'(x), I1(x), I1'(x), K0(x), K0'(x), K1(x), K1'(x).
!
  implicit none

  real ( kind = 8 ), save, dimension ( 12 ) :: a = (/ &
    0.125D+00, 7.03125D-02, &
    7.32421875D-02, 1.1215209960938D-01, &
    2.2710800170898D-01, 5.7250142097473D-01, &
    1.7277275025845D+00, 6.0740420012735D+00, &
    2.4380529699556D+01, 1.1001714026925D+02, &
    5.5133589612202D+02, 3.0380905109224D+03 /)
  real ( kind = 8 ), save, dimension ( 8 ) :: a1 = (/ &
    0.125D+00, 0.2109375D+00, &
    1.0986328125D+00, 1.1775970458984D+01, &
    2.1461706161499D+02, 5.9511522710323D+03, &
    2.3347645606175D+05, 1.2312234987631D+07 /)
  real ( kind = 8 ), save, dimension ( 12 ) :: b = (/ &
    -0.375D+00, -1.171875D-01, &
    -1.025390625D-01, -1.4419555664063D-01, &
    -2.7757644653320D-01, -6.7659258842468D-01, &
    -1.9935317337513D+00, -6.8839142681099D+00, &
    -2.7248827311269D+01, -1.2159789187654D+02, &
    -6.0384407670507D+02, -3.3022722944809D+03 /)

  real ( kind = 8 ) bi0
  real ( kind = 8 ) bi1
  real ( kind = 8 ) ca
  integer ( kind = 4 ) k
  integer ( kind = 4 ) k0
  real ( kind = 8 ) pi
  real ( kind = 8 ) r
  real ( kind = 8 ) x
  real ( kind = 8 ) x2
  real ( kind = 8 ) xr

  pi = 3.141592653589793D+00
  x2 = x * x

  if ( x == 0.0D+00 ) then

    bi0 = 1.0D+00
    bi1 = 0.0D+00
    return

  else if ( x <= 18.0D+00 ) then

    bi0 = 1.0D+00
    r = 1.0D+00
    do k = 1, 50
      r = 0.25D+00 * r * x2 / ( k * k )
      bi0 = bi0 + r
      if ( abs ( r / bi0 ) < 1.0D-15 ) then
        exit
      end if
    end do

    bi1 = 1.0D+00
    r = 1.0D+00
    do k = 1, 50
      r = 0.25D+00 * r * x2 / ( k * ( k + 1 ) )
      bi1 = bi1 + r
      if ( abs ( r / bi1 ) < 1.0D-15 ) then
        exit
      end if
    end do

    bi1 = 0.5D+00 * x * bi1

  else

    if ( x < 35.0D+00 ) then
      k0 = 12
    else if ( x < 50.0D+00 ) then
      k0 = 9
    else
      k0 = 7
    end if

    ca = exp ( x ) / sqrt ( 2.0D+00 * pi * x )
    bi0 = 1.0D+00
    xr = 1.0D+00 / x
    do k = 1, k0
      bi0 = bi0 + a(k) * xr ** k
    end do
    bi0 = ca * bi0
    bi1 = 1.0D+00
    do k = 1, k0
      bi1 = bi1 + b(k) * xr ** k
    end do
    bi1 = ca * bi1

  end if
  return
end

SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!--------- ----

! Evaluates the algebraic equations or ODE right hand side

! Input arguments :
!      NDIM   :   Dimension of the algebraic or ODE system
!      U      :   State variables
!      ICP    :   Array indicating the free parameter(s)
!      PAR    :   Equation parameters

! Values to be returned :
!      F      :   Equation or ODE right hand side values

! Normally unused Jacobian arguments : IJAC, DFDU, DFDP (see manual)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM),DFDP(NDIM,*)

  DOUBLE PRECISION x, lambda, beta, epsil, b0, b1

  x = U(1)

  lambda = PAR(1)
  beta = PAR(2)
  epsil = PAR(3)

  call ik01a (x**2*beta/2, b0, b1)

  F(1)= beta*(-DEXP(-beta*(x**4/4 - (lambda*x**2)/2 + x*epsil)))*(-lambda*x*b0 + epsil*b0 - x*b1 + x**3*b0)

END SUBROUTINE FUNC

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

SUBROUTINE STPNT(NDIM,U,PAR,T)
!--------- -----

! Input arguments :
!      NDIM   :   Dimension of the algebraic or ODE system

! Values to be returned :
!      U      :   A starting solution vector
!      PAR    :   The corresponding equation-parameter values

! Note : For time- or space-dependent solutions this subroutine has
!        the scalar input parameter T contains the varying time or space
!        variable value.

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: T

! Initialize the equation parameters
  PAR(1:3) = (/ LAMBDAINPUT, BETAINPUT, ETAINPUT/)

! Initialize the solution
  U(1) = X0INPUT

END SUBROUTINE STPNT

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!--------- ----

! Boundary Conditions

! Input arguments :
!      NDIM   :   Dimension of the ODE system
!      PAR    :   Equation parameters
!      ICP    :   Array indicating the free parameter(s)
!      NBC    :   Number of boundary conditions
!      U0     :   State variable values at the left boundary
!      U1     :   State variable values at the right boundary

! Values to be returned :
!      FB     :   The values of the boundary condition functions

! Normally unused Jacobian arguments : IJAC, DBC (see manual)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
  DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

!X FB(1)=
!X FB(2)=

END SUBROUTINE BCND

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!--------- ----

! Integral Conditions

! Input arguments :
!      NDIM   :   Dimension of the ODE system
!      PAR    :   Equation parameters
!      ICP    :   Array indicating the free parameter(s)
!      NINT   :   Number of integral conditions
!      U      :   Value of the vector function U at `time' t

! The following input arguments, which are normally not needed,
! correspond to the preceding point on the solution branch
!      UOLD   :   The state vector at 'time' t
!      UDOT   :   Derivative of UOLD with respect to arclength
!      UPOLD  :   Derivative of UOLD with respect to `time'

! Normally unused Jacobian arguments : IJAC, DINT

! Values to be returned :
!      FI     :   The value of the vector integrand

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
  DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)

!X FI(1)=

END SUBROUTINE ICND

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE FOPT(NDIM,U,ICP,PAR,IJAC,FS,DFDU,DFDP)
!--------- ----
!
! Defines the objective function for algebraic optimization problems
!
! Supplied variables :
!      NDIM   :   Dimension of the state equation
!      U      :   The state vector
!      ICP    :   Indices of the control parameters
!      PAR    :   The vector of control parameters
!
! Values to be returned :
!      FS      :   The value of the objective function
!
! Normally unused Jacobian argument : IJAC, DFDP

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: FS
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM),DFDP(*)

!X FS=

END SUBROUTINE FOPT

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE PVLS(NDIM,U,PAR)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

!----------------------------------------------------------------------
! NOTE :
! Parameters set in this subroutine should be considered as ``solution
! measures'' and be used for output purposes only.
!
! They should never be used as `true'' continuation parameters.
!
! They may, however, be added as ``over-specified parameters'' in the
! parameter list associated with the AUTO-Constant NICP, in order to
! print their values on the screen and in the ``p.xxx file.
!
! They may also appear in the list associated with AUTO-Constant NUZR.
!
!----------------------------------------------------------------------
! For algebraic problems the argument U is, as usual, the state vector.
! For differential equations the argument U represents the approximate
! solution on the entire interval [0,1]. In this case its values must
! be accessed indirectly by calls to GETP, as illustrated below.
!----------------------------------------------------------------------
!
! Set PAR(2) equal to the L2-norm of U(1)
!X PAR(2)=GETP('NRM',1,U)
!
! Set PAR(3) equal to the minimum of U(2)
!X PAR(3)=GETP('MIN',2,U)
!
! Set PAR(4) equal to the value of U(2) at the left boundary.
!X PAR(4)=GETP('BV0',2,U)
!
! Set PAR(5) equal to the pseudo-arclength step size used.
!X PAR(5)=GETP('STP',1,U)
!
!----------------------------------------------------------------------
! The first argument of GETP may be one of the following:
!        'NRM' (L2-norm),     'MAX' (maximum),
!        'INT' (integral),    'BV0 (left boundary value),
!        'MIN' (minimum),     'BV1' (right boundary value).
!
! Also available are
!   'STP' (Pseudo-arclength step size used).
!   'FLD' (`Fold function', which vanishes at folds).
!   'BIF' (`Bifurcation function', which vanishes at singular points).
!   'HBF' (`Hopf function'; which vanishes at Hopf points).
!   'SPB' ( Function which vanishes at secondary periodic bifurcations).
!----------------------------------------------------------------------

END SUBROUTINE PVLS

!----------------------------------------------------------------------
!----------------------------------------------------------------------