module test_logspace
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_kinds, only: sp, dp, int8, int16, int32, int64
    use stdlib_math, only: logspace, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH

    implicit none

    ! Testing logspace
    !
    ! logspace should return a rank 1 array of values equally logarithmically spaced
    ! from the base**start to base**end, using 10 as the base. If no length
    ! is specified, return a rank 1 array with 50 elements.
    !
    ! Also test to verify that the proportion between adjacent elements is constant within
    ! a certain tolerance

    real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp)
    real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed

contains

    !> Collect all exported unit tests
    subroutine collect_logspace(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("logspace_sp", test_logspace_sp), &
            new_unittest("logspace_dp", test_logspace_dp), &
            new_unittest("logspace_default", test_logspace_default), &
            new_unittest("logspace_base_2", test_logspace_base_2), &
            new_unittest("logspace_base_2_cmplx_start", test_logspace_base_2_cmplx_start), &
            new_unittest("logspace_base_i_int_start", test_logspace_base_i_int_start) &
            ]

    end subroutine collect_logspace

    subroutine test_logspace_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 20
        real(sp), parameter :: start = 0.0_sp
        real(sp), parameter :: end = 2.0_sp

        real(sp) :: expected_proportion
        integer :: i

        real(sp), allocatable :: x(:)

        x = logspace(start, end, n)

        expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )

        call check(error, size(x), n, "Array not allocated to appropriate size")
        if (allocated(error)) return
        call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start")
        if (allocated(error)) return
        call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end")
        if (allocated(error)) return

        do i = 1, n-1

            call check(error, x(i + 1) / x(i), expected_proportion, &
                & thr=abs(expected_proportion) * TOLERANCE_SP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_logspace_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 10
        real(dp), parameter :: start = 1.0_dp
        real(dp), parameter :: end = 0.0_dp
        real(dp) :: expected_proportion
        integer :: i

        real(dp), allocatable :: x(:)

        x = logspace(start, end, n)

        expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )

        call check(error, size(x), n, "Array not allocated to appropriate size")
        if (allocated(error)) return
        call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start")
        if (allocated(error)) return
        call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end")
        if (allocated(error)) return

        do i = 1, n-1

            call check(error, x(i + 1) / x(i), expected_proportion, &
                & thr=abs(expected_proportion) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_logspace_default(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(dp), parameter :: start = 0.0_dp
        real(dp), parameter :: end = 1.0_dp
        integer, parameter :: n = DEFAULT_LOGSPACE_LENGTH
        real(dp) :: expected_proportion
        integer :: i

        real(dp), allocatable :: x(:)

        x = logspace(start, end)

        expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )

        call check(error, size(x), n, "Array not allocated to appropriate size")
        if (allocated(error)) return
        call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start")
        if (allocated(error)) return
        call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end")
        if (allocated(error)) return

        do i = 1, n-1

            call check(error, x(i + 1) / x(i), expected_proportion, &
                & thr=abs(expected_proportion) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_logspace_base_2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 10
        real(dp), parameter :: start = 1.0_dp
        real(dp), parameter :: end = 10.0_dp
        integer, parameter :: base = 2
        integer :: i
        real(dp) :: expected_proportion

        real(dp), allocatable :: x(:)

        x = logspace(start, end, n, base)

        expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) )

        call check(error, size(x), n, "Array not allocated to appropriate size")
        if (allocated(error)) return
        call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start")
        if (allocated(error)) return
        call check(error, x(n), base ** end, "Final value of array is not equal to 2^end")
        if (allocated(error)) return

        do i = 1, n-1

            call check(error, x(i + 1) / x(i), expected_proportion, &
                & thr=abs(expected_proportion) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_logspace_base_2_cmplx_start(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 10
        complex(dp), parameter :: start = (1, 0)
        complex(dp), parameter :: end = (0, 1)
        integer, parameter :: base = 2
        complex(dp) :: expected_proportion
        integer :: i

        complex(dp), allocatable :: x(:)

        x = logspace(start, end, n, base)

        expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) )

        call check(error, size(x), n, "Array not allocated to appropriate size")
        if (allocated(error)) return
        call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start")
        if (allocated(error)) return
        call check(error, x(n), base ** end, "Final value of array is not equal to 2^end")
        if (allocated(error)) return

        do i = 1, n-1

            call check(error, x(i + 1) / x(i), expected_proportion, &
                & thr=abs(expected_proportion) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_logspace_base_i_int_start(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 5
        integer, parameter :: start = 1
        integer, parameter :: end = 5
        complex(dp), parameter :: base = (0, 1) ! i
        complex(dp) :: expected_proportion
        integer :: i

        complex(dp), allocatable :: x(:)

        x = logspace(start, end, n, base)

        expected_proportion = base ** ( ( end - start ) / ( n - 1 ) )

        call check(error, size(x), n, "Array not allocated to appropriate size")
        if (allocated(error)) return
        call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start")
        if (allocated(error)) return
        call check(error, x(n), base ** end, "Final value of array is not equal to 2^end")
        if (allocated(error)) return

        do i = 1, n-1

            call check(error, x(i + 1) / x(i), expected_proportion, &
                & thr=abs(expected_proportion) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

end module

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_logspace, only : collect_logspace
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("logspace", collect_logspace) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program tester


module special_functions
  use numerical_constants
  implicit none

contains
  subroutine gen_assoc_legendre_pol(x_pts, n_pts, lmax, alp)
    implicit none
    integer, intent(in) :: n_pts, lmax
    real(kind=dp), intent(in) :: x_pts(n_pts)
    real(kind=dp), intent(out) :: alp(n_pts, 0:lmax, -lmax:lmax)
    integer :: l, m, fact(lmax)

    call calc_factorials(lmax, fact)

    alp(:, 0, 0) = 1.0d0
    do l=1,lmax
        alp(:,l,l-1)=x_pts*(2.0d0*(l-1.0d0)+1.0d0)*alp(:,l-1,l-1)
        alp(:,l,-l+1)=(-1)**(l-1)*alp(:,l,l-1)/fact(l+l-1)  !m=l-1
        alp(:,l,l)=-(2.0d0*(l-1.0d0)+1.0d0)*sqrt(1.d0-x_pts*x_pts)*alp(:,l-1,l-1)
        alp(:,l,-l)=(-1)**l*alp(:,l,l)/fact(l+l)
        do m=l-2,1,-1
            alp(:,l,m)=(x_pts*(2*l-1)*alp(:,l-1,m)-(l+m-1)*alp(:,l-2,m))/float(l-m)
            alp(:,l,-m)=(-1)**m*fact(l-m)*alp(:,l,m)/fact(l+m)
        end do
        alp(:,l,0)=(x_pts*(2*l-1)*alp(:,l-1,0)-(l-1)*alp(:,l-2,0))/float(l)
    end do
  end subroutine gen_assoc_legendre_pol

  subroutine calc_factorials(nmax, fact)
    implicit none
    integer, intent(in) :: nmax
    integer, intent(out) :: fact(nmax)
    integer :: i

    fact(0) = 1
    do i=1,nmax
       fact(i) = fact(i-1)*i
    end do

  end subroutine calc_factorials
end module special_functions


! from http://calcul.math.cnrs.fr/Documents/Ecoles/2010/f2py-cours.pdf
! Pierre Navaro

! tableaux:
!  - attention: passer le bon type sinon, f2py effectue une copie
!    et travaille sur une variable temporaire (sans rien dire!)
!  - si multidim: specifier "order='F'" pour le tableau numpy!

subroutine move( positions, vitesses, dt, n)
    integer, intent(in) :: n
    real(8), intent(in) :: dt
    real(8), dimension(n,3), intent(in) :: vitesses
    real(8), dimension(n,3) :: positions
    do i = 1, n
        positions(i,:) = positions(i,:) + dt*vitesses(i,:)
    end do
end subroutine move

! creation d'un tableau et retour a python.
! f2py se charge de la gestion de mémoire
subroutine create_array(A, n)
    integer, intent(in) :: n
    real(8), dimension(n,3), intent(out) :: A
    do i = 1, n
        do j = 1, n
            A(i,j) = i+j
        enddo
    enddo
end subroutine create_array

!
! produit matriciel
!

subroutine mult_array(A, B, C, m, n, k)

    real(8), dimension(m,k), intent(in) :: A
    real(8), dimension(k,n), intent(in) :: B
    integer :: m,n,k
    real(8), dimension(m,n), intent(out) :: C

    real(8) ::s
    integer :: i,j,l

    do i=1, m
        do j = 1, n
            s = 0.0
            do l = 1, k
                s = s + A(i,l)*B(l,j)
            enddo
            C(i,j) = s
        enddo
    enddo
end subroutine mult_array


let Rint (lo:Int) (hi:Int) :* = (x:Int. (and  (lo<=x)  (x<hi)));;

datatype BiTree (lo:Int) (hi:Int) =
  Empty
| Node of (mid:(Rint lo hi)) (left:(BiTree lo mid)) (right:(BiTree mid hi));;

let rec search (lo:Int) (hi:Int) (t:BiTree lo hi) (v:Rint lo hi) : Bool =
  caseBiTree lo hi t Bool
    (fn u => false)
    (fn i l r =>
     (or (i=v)
        (if[Bool] v < i
        then search lo i l v
        else search i hi r v)));;

let rec insert (lo:Int) (hi:Int) (t:BiTree lo hi) (v:Rint lo hi) : (BiTree lo hi) =
  caseBiTree lo hi t (BiTree lo hi)
    (fn u =>
       Node lo hi v (Empty lo v) (Empty v hi))
    (fn i l r =>
     if[(BiTree lo hi)] v < i /* err if i <= v  or  v <= i*/
     then Node lo hi i (insert lo i l /*err if r*/ (v/* err if i */+0)) r /* err if l */
     else Node lo hi i l (insert i hi r (v+0)));;

let rec sum (lo:Int) (hi:Int) (t:BiTree lo hi) : Int =
  caseBiTree lo hi t Int
    (fn u => 0)
    (fn i l r =>
      (sum lo i l) + (sum i hi r));;

let MININT : Int = 0-32767;;
let MAXINT : Int = 32767;;

let BTree = BiTree MININT MAXINT;;
let Int16 = Rint MININT MAXINT;;
let mt:BTree = Empty MININT MAXINT;;
let ins (t:BTree) (v:Int16) : BTree = insert MININT MAXINT t v;;
let get (t:BTree) (v:Int16) : Bool = search MININT MAXINT t v;;

let t : BTree = (ins (ins (ins mt 1) 2) 3);;

let Pos = Rint 1 MAXINT;;

let PTree = BiTree 1 MAXINT;;

let mtP:PTree = Empty 1 MAXINT;;
let insP (t:PTree) (v:Pos) : PTree = insert 1 MAXINT t v;;
let getP (t:PTree) (v:Pos) : Bool = search 1 MAXINT t v;;

let x = 0-3;;
let tP : PTree = (insP (insP (insP mtP 1) 2) x);;

(getP tP 2);; /* true */
(getP tP 4);; /* false */

let sumAny = sum MININT MAXINT;;
sumAny t;;
/* sumAny tP;; */


      SUBROUTINE gaussj(a,n,np,b,m,mp)
      INTEGER m,mp,n,np,NMAX
      REAL a(np,np),b(np,mp)
      PARAMETER (NMAX=50)
      INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX),ipiv(NMAX)
      REAL big,dum,pivinv
      do 11 j=1,n
        ipiv(j)=0
11    continue
      do 22 i=1,n
        big=0.
        do 13 j=1,n
          if(ipiv(j).ne.1)then
            do 12 k=1,n
              if (ipiv(k).eq.0) then
                if (abs(a(j,k)).ge.big)then
                  big=abs(a(j,k))
                  irow=j
                  icol=k
                endif
              else if (ipiv(k).gt.1) then
                pause 'singular matrix in gaussj'
              endif
12          continue
          endif
13      continue
        ipiv(icol)=ipiv(icol)+1
        if (irow.ne.icol) then
          do 14 l=1,n
            dum=a(irow,l)
            a(irow,l)=a(icol,l)
            a(icol,l)=dum
14        continue
          do 15 l=1,m
            dum=b(irow,l)
            b(irow,l)=b(icol,l)
            b(icol,l)=dum
15        continue
        endif
        indxr(i)=irow
        indxc(i)=icol
        if (a(icol,icol).eq.0.) pause 'singular matrix in gaussj'
        pivinv=1./a(icol,icol)
        a(icol,icol)=1.
        do 16 l=1,n
          a(icol,l)=a(icol,l)*pivinv
16      continue
        do 17 l=1,m
          b(icol,l)=b(icol,l)*pivinv
17      continue
        do 21 ll=1,n
          if(ll.ne.icol)then
            dum=a(ll,icol)
            a(ll,icol)=0.
            do 18 l=1,n
              a(ll,l)=a(ll,l)-a(icol,l)*dum
18          continue
            do 19 l=1,m
              b(ll,l)=b(ll,l)-b(icol,l)*dum
19          continue
          endif
21      continue
22    continue
      do 24 l=n,1,-1
        if(indxr(l).ne.indxc(l))then
          do 23 k=1,n
            dum=a(k,indxr(l))
            a(k,indxr(l))=a(k,indxc(l))
            a(k,indxc(l))=dum
23        continue
        endif
24    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/gaussj.for


program poly
! Polymorphic-like real kind at compile time
!
! Output:
! cmake -Drealbits=32      2pi   6.28318548
! cmake -Drealbits=64      2pi   6.2831853071795862
! cmake -Drealbits=128     2pi   6.28318530717958647692528676655900559

use, intrinsic:: iso_fortran_env
implicit none (type, external)

@real_prec@

real(wp), parameter :: pi = 4._wp * atan(1._wp)

print *,'2pi',timestwo(pi)

contains

elemental real(wp) function timestwo(a) result(a2)

real(wp), intent(in) :: a

a2 = 2*a

end function timestwo

end program


module funcs
implicit none
contains

real(kind=8) function f(x)
   real(kind=8) x

   f = 5*x*x*x + 2*x*x + 120
end function f

real(kind=8) function df_dx(x)
   real(kind=8) x

   df_dx = 15*x*x + 4*x
end function df_dx

subroutine check_NaN (x, label)
   real(kind=8), intent(in) :: x
   character(len=5), intent(in) :: label

   if (isnan(x)) then
      write(*,'(A4,A5,A12)') "... ", label, " is a NaN ..."
      stop
   end if
end subroutine check_NaN

end module funcs


************************************************************************
* General collection of routines which might help somewhere...
************************************************************************

************************************************************************
* Linear rescale
*
* Scales a coordinate x linearly from the interval [a,b] to the
* interval [c,d].
*
* In:
*   x     - coordinate to be rescaled
*   [a,b] - source interval
*   [c,d] - destination interval
*
* Out:
*   y     - Rescaled coordinate
************************************************************************

      SUBROUTINE LRSCLE (X,A,B,C,D,Y)

      IMPLICIT NONE

      DOUBLE PRECISION X,A,B,C,D,Y

      DOUBLE PRECISION D1,D2,D3

C     Calculate the coefficients of the transformation
C         D1*A+D2 = C, D1*B+D2 = D.
C     Use them to calculate Y=D1*X+D2.

      IF (A.EQ.B) THEN
        Y = C
        RETURN
      END IF

      D3 = 1D0/(A-B)
      D1 = (C-D)*D3
      D2 = (-B*C+A*D)*D3

      Y = D1*X+D2

      END


!> \brief \b DROTG
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!  DROTG constructs a plane rotation
!     [  c  s ] [ a ] = [ r ]
!     [ -s  c ] [ b ]   [ 0 ]
!  satisfying c**2 + s**2 = 1.
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> The computation uses the formulas
!>    sigma = sgn(a)    if |a| >  |b|
!>          = sgn(b)    if |b| >= |a|
!>    r = sigma*sqrt( a**2 + b**2 )
!>    c = 1; s = 0      if r = 0
!>    c = a/r; s = b/r  if r != 0
!> The subroutine also computes
!>    z = s    if |a| > |b|,
!>      = 1/c  if |b| >= |a| and c != 0
!>      = 1    if c = 0
!> This allows c and s to be reconstructed from z as follows:
!>    If z = 1, set c = 0, s = 1.
!>    If |z| < 1, set c = sqrt(1 - z**2) and s = z.
!>    If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2).
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION
!>          On entry, the scalar a.
!>          On exit, the scalar r.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION
!>          On entry, the scalar b.
!>          On exit, the scalar z.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is DOUBLE PRECISION
!>          The scalar c.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is DOUBLE PRECISION
!>          The scalar s.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
!  =====================================================================
subroutine DROTG( a, b, c, s )
   integer, parameter :: wp = kind(1.d0)
!
!  -- Reference BLAS level1 routine --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Constants ..
   real(wp), parameter :: zero = 0.0_wp
   real(wp), parameter :: one  = 1.0_wp
!  ..
!  .. Scaling constants ..
   real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( &
      minexponent(0._wp)-1, &
      1-maxexponent(0._wp) &
   )
   real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( &
      1-minexponent(0._wp), &
      maxexponent(0._wp)-1 &
   )
!  ..
!  .. Scalar Arguments ..
   real(wp) :: a, b, c, s
!  ..
!  .. Local Scalars ..
   real(wp) :: anorm, bnorm, scl, sigma, r, z
!  ..
   anorm = abs(a)
   bnorm = abs(b)
   if( anorm == zero ) then
      c = zero
      s = one
      a = b
      b = one
   else if( bnorm == zero ) then
      c = one
      s = zero
      b = zero
   else
      scl = min( safmax, max( safmin, anorm, bnorm ) )
      if( anorm > bnorm ) then
         sigma = sign(one,a)
      else
         sigma = sign(one,b)
      end if
      r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) )
      c = a/r
      s = b/r
      if( anorm > bnorm ) then
         z = s
      else if( c /= zero ) then
         z = one/c
      else
         z = one
      end if
      a = r
      b = z
   end if
   return
end subroutine


!************************************************************

SUBROUTINE zludcmp(A,det,n)
IMPLICIT NONE

INTEGER*4, INTENT(IN) :: n
COMPLEX*16, DIMENSION(0:n-1,0:n-1), INTENT(IN) :: A
COMPLEX*16, INTENT(OUT) :: det

! ******
! For input variables with zero-based indexing:
! Calculation of det(A) using LU decomposition. Note that in general,
! numerical overflow may result unless LOG(det(A)) is formed instead.

COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: A_aux
INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv
INTEGER :: m,i,info

ALLOCATE(A_aux(1:n,1:n))
ALLOCATE(ipiv(1:n))

A_aux(1:n,1:n) = A(0:n-1,0:n-1)

m = n
CALL ZGETRF(m,m,A_aux,m,ipiv,info)

IF (info /= 0) THEN

	WRITE (*,*) 'ZGETRF failed in zludcmp, code: ',info
	STOP

END IF

det = 1.d0

DO i = 1,n

	IF (ipiv(i) /= i) det = -det * A_aux(i,i)
	IF (ipiv(i) == i) det = det * A_aux(i,i)

END DO

DEALLOCATE(A_aux,ipiv)

END SUBROUTINE zludcmp

!************************************************************

SUBROUTINE zludcmp_ratio(A,detratio,ldetref,n)
IMPLICIT NONE

INTEGER*4, INTENT(IN) :: n
COMPLEX*16, DIMENSION(0:n-1,0:n-1), INTENT(IN) :: A
DOUBLE PRECISION, INTENT(IN) :: ldetref
COMPLEX*16 :: ldet
COMPLEX*16, INTENT(OUT) :: detratio

! ******
! For input variables with zero-based indexing:
! Calculation of det(A)/detref = det(A)/exp(ldetref) using LU decomposition,
! where detref is positive

COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: A_aux
INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv
INTEGER :: m,i,info

ALLOCATE(A_aux(1:n,1:n))
ALLOCATE(ipiv(1:n))

A_aux(1:n,1:n) = A(0:n-1,0:n-1)

m = n
CALL ZGETRF(m,m,A_aux,m,ipiv,info)

IF (info /= 0) THEN

	WRITE (*,*) 'ZGETRF failed in zludcmp, code: ',info
	STOP

END IF

ldet = 0.d0

DO i = 1,n

	IF (ipiv(i) /= i) ldet = ldet + LOG(-A_aux(i,i))
	IF (ipiv(i) == i) ldet = ldet + LOG(A_aux(i,i))

END DO

detratio = exp(ldet-ldetref)

!det = 1.d0
!
!DO i = 1,n
!
!	IF (ipiv(i) /= i) det = -det * A_aux(i,i)
!	IF (ipiv(i) == i) det = det * A_aux(i,i)
!
!END DO

DEALLOCATE(A_aux,ipiv)

END SUBROUTINE zludcmp_ratio

!************************************************************

SUBROUTINE zludcmp_log(A,ldet,n)
IMPLICIT NONE

INTEGER*4, INTENT(IN) :: n
COMPLEX*16, DIMENSION(0:n-1,0:n-1), INTENT(IN) :: A
COMPLEX*16, INTENT(OUT) :: ldet

! ******
! For input variables with zero-based indexing:
! Calculation of log(det(A)) using LU decomposition.

COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: A_aux
INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv
INTEGER :: m,i,info

ALLOCATE(A_aux(1:n,1:n))
ALLOCATE(ipiv(1:n))

A_aux(1:n,1:n) = A(0:n-1,0:n-1)

m = n
CALL ZGETRF(m,m,A_aux,m,ipiv,info)

IF (info /= 0) THEN

	WRITE (*,*) 'ZGETRF failed in zludcmp, code: ',info
	STOP

END IF

ldet = 0.d0

DO i = 1,n

	IF (ipiv(i) /= i) ldet = ldet + LOG(-A_aux(i,i))
	IF (ipiv(i) == i) ldet = ldet + LOG(A_aux(i,i))

END DO

!det = 1.d0
!
!DO i = 1,n
!
!	IF (ipiv(i) /= i) det = -det * A_aux(i,i)
!	IF (ipiv(i) == i) det = det * A_aux(i,i)
!
!END DO

DEALLOCATE(A_aux,ipiv)

END SUBROUTINE zludcmp_log

!***********************************************************

SUBROUTINE zdoinv(A,x,det,n)
IMPLICIT NONE

INTEGER*4, INTENT(IN) :: n
COMPLEX*16, DIMENSION(0:n-1,0:n-1), INTENT(IN) :: A
COMPLEX*16, DIMENSION(0:n-1,0:n-1), INTENT(OUT) :: x
COMPLEX*16, INTENT(OUT) :: det

! ******
! For input variables with zero-based indexing:
! Calculation of A^-1 from A*x = I including det(A).

COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: A_aux,B_aux
INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv
INTEGER :: m,nRhs,i,info

ALLOCATE(A_aux(1:n,1:n))
ALLOCATE(ipiv(1:n))

A_aux(1:n,1:n) = A(0:n-1,0:n-1)

m = n
CALL ZGETRF(m,m,A_aux,m,ipiv,info)

IF (info /= 0) THEN

	WRITE (*,*) 'ZGETRF failed in zdoinv, code: ',info
	STOP

END IF

det = 1.d0

DO i = 1,n

	IF (ipiv(i) /= i) det = -det * A_aux(i,i)
	IF (ipiv(i) == i) det = det * A_aux(i,i)

END DO

nRhs = n
ALLOCATE(B_aux(1:n,1:nRhs))
B_aux = 0.d0

DO i = 1,nRhs

	B_aux(i,i) = 1.d0

END DO

CALL ZGETRS('N',m,nRhs,A_aux,m,ipiv,B_aux,m,info)

IF (info /= 0) THEN

	WRITE (*,*) 'ZGETRS failed in zdoinv, code: ',info
	STOP

END IF

x(0:n-1,0:n-1) = B_aux(1:n,1:n)

DEALLOCATE(A_aux,B_aux,ipiv)

END SUBROUTINE zdoinv

!***********************************************************

SUBROUTINE zdoinv_log(A,x,ldet,n)
IMPLICIT NONE

INTEGER*4, INTENT(IN) :: n
COMPLEX*16, DIMENSION(0:n-1,0:n-1), INTENT(IN) :: A
COMPLEX*16, DIMENSION(0:n-1,0:n-1), INTENT(OUT) :: x
COMPLEX*16, INTENT(OUT) :: ldet

! ******
! For input variables with zero-based indexing:
! Calculation of A^-1 from A*x = I including det(A).

COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: A_aux,B_aux
INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv
INTEGER :: m,nRhs,i,info

ALLOCATE(A_aux(1:n,1:n))
ALLOCATE(ipiv(1:n))

A_aux(1:n,1:n) = A(0:n-1,0:n-1)

m = n
CALL ZGETRF(m,m,A_aux,m,ipiv,info)

IF (info /= 0) THEN

	WRITE (*,*) 'ZGETRF failed in zdoinv, code: ',info
	STOP

END IF

ldet = 0.d0

DO i = 1,n

	IF (ipiv(i) /= i) ldet = ldet + LOG(-A_aux(i,i))
	IF (ipiv(i) == i) ldet = ldet + LOG(A_aux(i,i))

END DO

! det = 1.d0
!
! DO i = 1,n
!
!	IF (ipiv(i) /= i) det = -det * A_aux(i,i)
!	IF (ipiv(i) == i) det = det * A_aux(i,i)
!
! END DO

nRhs = n
ALLOCATE(B_aux(1:n,1:nRhs))
B_aux = 0.d0

DO i = 1,nRhs

	B_aux(i,i) = 1.d0

END DO

CALL ZGETRS('N',m,nRhs,A_aux,m,ipiv,B_aux,m,info)

IF (info /= 0) THEN

	WRITE (*,*) 'ZGETRS failed in zdoinv, code: ',info
	STOP

END IF

x(0:n-1,0:n-1) = B_aux(1:n,1:n)

DEALLOCATE(A_aux,B_aux,ipiv)

END SUBROUTINE zdoinv_log

!*************************************************************


      SUBROUTINE MTXMUL33(IFLAG,AMAT,BMAT,CMAT)
      IMPLICIT REAL*8(A-H,O-Z)
C
C  FOR 3-BY-3 MATRICS AMAT AND BMAT, FORM ONE OF THE PRODUCTS
C
C                 CMAT =  AMAT * BMAT
C                 CMAT =  AMAT * (BMAT-TRANSPOSE)
C                 CMAT =  (AMAT-TRANSPOSE) * BMAT
C                 CMAT =  (AMAT-TRANSPOSE) * (BMAT-TRANSPOSE)
C
C       IN THE CALLING PROGRAM
C
C                 - CMAT MAY BE ONE OF AMAT OR BMAT
C                 - AMAT AND BMAT MAY BE THE SAME MATRIX
C
C                 EXAMPLES:
C                  CALL MTXMUL33(IFLAG,A,B,C)
C                  CALL MTXMUL33(IFLAG,A,A,A)
C                  CALL MTXMUL33(IFLAG,A,B,A)
C                  CALL MTXMUL33(IFLAG(A,A,C)
C
C  VAR   DIM       TYPE   I/O   DESCRIPTION
C  ---   ---       ----   ---   -----------
C
C  IFLAG  1        I*4     I    FLAG TELLING THE ROUTINE WHICH PRODUCT
C                               TO FORM.
C
C                                = 1, CMAT = AMAT * BMAT
C                                = 2, CMAT = AMAT * (BMAT-TR)
C                                = 3, CMAT = (AMAT-TR) * BMAT
C                                = 4, CMAT = (AMAT-TR) * (BMAT-TR)
C                                = OTHERWISE, NO PRODUCT FORMED AND
C                                  CMAT IS FILLED WITH 1.D10 VALUES.
C                                  THIS IS THE ONLY ERROR INDICATION.
C
C  AMAT  3,3       R*8     I    INPUT MATRIX.
C
C  BMAT  3,3       R*8     I    INPUT MATRIX.
C
C  CMAT  3,3       R*8     O    OUTPUT MATRIX.
C
C
C***********************************************************************
C
C  CODED BY C PETRUZZO. 5/83.
C  MODIFIED............
C
C***********************************************************************
C
C
      REAL*8 AMAT(3,3),BMAT(3,3),CMAT(3,3),HOLD(3,3)
C
      IF(IFLAG.EQ.1) THEN     ! AMAT * BMAT
        DO 100 I=1,3
        DO 100 J=1,3
        TEMP=0.D0
        DO 101 K=1,3
  101   TEMP=TEMP + AMAT(I,K) * BMAT(K,J)
  100   HOLD(I,J)=TEMP
        GO TO 5000
        END IF
C
      IF(IFLAG.EQ.2) THEN      ! AMAT * BMAT-TR
        DO 200 I=1,3
        DO 200 J=1,3
        TEMP=0.D0
        DO 201 K=1,3
  201   TEMP=TEMP + AMAT(I,K) * BMAT(J,K)
  200   HOLD(I,J)=TEMP
        GO TO 5000
        END IF
C
      IF(IFLAG.EQ.3) THEN      ! AMAT-TR * BMAT
        DO 300 I=1,3
        DO 300 J=1,3
        TEMP=0.D0
        DO 301 K=1,3
  301   TEMP=TEMP + AMAT(K,I) * BMAT(K,J)
  300   HOLD(I,J)=TEMP
        GO TO 5000
        END IF
C
      IF(IFLAG.EQ.4) THEN      ! AMAT-TR * BMAT-TR
        DO 400 I=1,3
        DO 400 J=1,3
        TEMP=0.D0
        DO 401 K=1,3
  401   TEMP=TEMP + AMAT(K,I) * BMAT(J,K)
  400   HOLD(I,J)=TEMP
        GO TO 5000
        END IF
C
      DO 9900 I=1,3     ! WE GET THIS FAR ONLY WHEN IFLAG IS INVALID.
      DO 9900 J=1,3
 9900 HOLD(I,J)=1.D10
C
C
 5000 CONTINUE       ! LOAD MATRIX TO BE RETURNED
      DO 1000 I=1,3
      DO 1000 J=1,3
 1000 CMAT(I,J)=HOLD(I,J)
C
      RETURN
      END


      PROGRAM xqrupdt
C     driver for routine qrdupd
      INTEGER NP
      PARAMETER(NP=20)
      INTEGER i,j,k,l,m,n
      REAL con,a(NP,NP),au(NP,NP),c(NP),d(NP),q(NP,NP),qt(NP,NP),
     *     r(NP,NP),s(NP,NP),u(NP),v(NP),x(NP,NP)
      CHARACTER txt*3
      LOGICAL sing
      open(7,file='MATRX1.DAT',status='old')
      read(7,*)
10    read(7,*)
      read(7,*) n,m
      read(7,*)
      read(7,*) ((a(k,l), l=1,n), k=1,n)
      read(7,*)
      read(7,*) ((s(k,l), k=1,n), l=1,m)
C     print out a-matrix for comparison with product of Q and R
C     decomposition matrices.
      write(*,*) 'Original matrix:'
      do 11 k=1,n
        write(*,'(1x,6f12.6)') (a(k,l), l=1,n)
11      continue
C     updated matrix we'll use later
      do 13 k=1,n
        do 12 l=1,n
            au(k,l)=a(k,l)+s(k,1)*s(l,2)
12        continue
13      continue
C     perform the initial decomposition
      call qrdcmp(a,n,NP,c,d,sing)
      if (sing) write(*,*) 'Singularity in QR decomposition.'
C     find the Q and R matrices
      do 15 k=1,n
        do 14 l=1,n
          if (l.gt.k) then
            r(k,l)=a(k,l)
            q(k,l)=0.0
          else if (l.lt.k) then
            r(k,l)=0.0
            q(k,l)=0.0
          else
            r(k,l)=d(k)
            q(k,l)=1.0
          endif
14        continue
15      continue
      do 23 i=n-1,1,-1
        con=0.0
        do 16 k=i,n
          con=con+a(k,i)**2
16        continue
        con=con/2.0
        do 19 k=i,n
          do 18 l=i,n
            qt(k,l)=0.0
            do 17 j=i,n
              qt(k,l)=qt(k,l)+q(j,l)*a(k,i)*a(j,i)/con
17            continue
18          continue
19        continue
        do 22 k=i,n
          do 21 l=i,n
            q(k,l)=q(k,l)-qt(k,l)
21          continue
22        continue
23      continue
C     compute product of Q and R matrices for comparison with original matrix.
      do 26 k=1,n
        do 25 l=1,n
          x(k,l)=0.0
          do 24 j=1,n
            x(k,l)=x(k,l)+q(k,j)*r(j,l)
24          continue
25        continue
26      continue
      write(*,*) 'Product of Q and R matrices:'
      do 27 k=1,n
          write(*,'(1x,6f12.6)') (x(k,l), l=1,n)
27        continue
      write(*,*) 'Q matrix of the decomposition:'
      do 28 k=1,n
        write(*,'(1x,6f12.6)') (q(k,l), l=1,n)
28      continue
      write(*,*) 'R matrix of the decomposition:'
      do 29 k=1,n
        write(*,'(1x,6f12.6)') (r(k,l), l=1,n)
29      continue
C     Q transpose
      do 32 k=1,n
        do 31 l=1,n
          qt(k,l)=q(l,k)
31        continue
32      continue
      do 34 k=1,n
        v(k)=s(k,2)
        u(k)=0.0
        do 33 l=1,n
          u(k)=u(k)+qt(k,l)*s(l,1)
33        continue
34      continue
      call qrupdt(r,qt,n,NP,u,v)
      do 37 k=1,n
        do 36 l=1,n
          x(k,l)=0.0
          do 35 j=1,n
            x(k,l)=x(k,l)+qt(j,k)*r(j,l)
35          continue
36        continue
37      continue
      write(*,*) 'Updated matrix:'
      do 38 k=1,n
        write(*,'(1x,6f12.6)') (au(k,l), l=1,n)
38      continue
      write(*,*) 'Product of new Q and R matrices:'
      do 39 k=1,n
          write(*,'(1x,6f12.6)') (x(k,l), l=1,n)
39        continue
      write(*,*) 'New Q matrix'
      do 41 k=1,n
        write(*,'(1x,6f12.6)') (qt(l,k), l=1,n)
41      continue
      write(*,*) 'New R matrix'
      do 42 k=1,n
        write(*,'(1x,6f12.6)') (r(k,l), l=1,n)
42      continue
      write(*,*) '***********************************'
      write(*,*) 'Press RETURN for next problem:'
      read(*,*)
      read(7,'(a3)') txt
      if (txt.ne.'END') goto 10
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xqrupdt.for


C
      SUBROUTINE QL (      M,     ME,   MMAX,      N,   NMAX,
     /                   MNN,      C,      D,      A,      B,
     /                    XL,     XU,      X,      U,    EPS,
     /                  MODE,   IOUT,  IFAIL, IPRINT,    WAR,
     /                  LWAR,   IWAR,  LIWAR)
C
C*********************************************************************
C
C
C         AN IMPLEMENTATION OF A PRIMAL-DUAL QUADRATIC PROGRAMMING
C
C                                METHOD
C
C
C   The Problem:
C
C   The code solves the strictly convex quadratic program
C
C             minimize      1/2 x^ C x + c^x
C             subject to    a_j^x + b_j  =  0  ,  j=1,...,m_e
C                           a_j^x + b_j  >= 0  ,  j=m+1,...,m
C                           x_l <= x <= x_u
C
C   with an n by n positive definite matrix C, an n-dimensional vector d,
C   an m by n matrix A=(a_1,...,a_m)^, and an m-vector b.
C
C
C
C   The Numerical Algorithm:
C
C   The subroutine reorganizes some data to solve the quadratic program
C   by a modification or a code going back to Powell (1983). The numerical
C   algorithm is the primal-dual method of Goldfarb and Idnani (1983).
C   First, a solution of the unconstrained quadratic program is found
C   proceeding from a Cholesky decomposition of C. Subsequently, violated
C   constraints are added successively. Constraints no longer considered
C   as active ones, are dropped. Numerically stable orthogonal
C   decomposition are applied to find intermediate minima on hyperplane
C   of the active constraints.
C
C
C
C   Usage:
C
C      CALL QL (      M,     ME,   MMAX,      N,   NMAX,
C     /             MNN,      C,      D,      A,      B,
C     /              XL,     XU,      X,      U,    EPS,
C     /            MODE,   IOUT,  IFAIL, IPRINT,    WAR,
C     /            LWAR,   IWAR,  LIWAR)
C
C
C
C   Definition of the parameters:
C
C   M :       Number of constraints.
C   ME :      Number of equality constraints.
C   MMAX :    Row dimension of array A containing linear constraints.
C             MMAX must be at least one and greater or equal to M.
C   N :       Number of optimization variables.
C   NMAX :    Row dimension of C. NMAX must be at least one and greater
C             or equal to N.
C   MNN :     Must be equal to M+N+N when calling QL, dimension of U.
C   C(NMAX,NMAX): Objective function matrix which should be symmetric
C             and positive definite. If MODE=0, C is supposed to be the
C             upper triangular factor of a Cholesky decomposition of C.
C   D(NMAX) : Contains the constant vector of the quadratic objective
C             function.
C   A(MMAX,NMAX): Matrix of the linear constraints, first ME rows for
C             equality, then M-ME rows for inequality constraints.
C   B(MMAX) : Constant values of linear constraints in the same order.
C   XL(N),XU(N) : On input, the one-dimensional arrays XL and XU must
C             contain the upper and lower bounds of the variables.
C   X(N) :    On return, X contains the optimal solution.
C   U(MNN) :  On return, U contains the multipliers subject to the
C             linear constraints and bounds. The first M locations
C             contain the multipliers of the M linear constraints, the
C             subsequent N locations the multipliers of the lower
C             bounds, and the final N locations the multipliers of the
C             upper bounds. At the optimal solution, all multipliers
C             with respect to inequality constraints should be
C             nonnegative.
C   EPS :     The user has to specify the desired final accuracy
C             (e.g. 1.0D-12). The parameter value should not be smaller
C             than the underlying machine precision.
C   MODE :    MODE=0 - The user provides an initial Cholesky factorization
C                      of C, stored in the upper triangular part of the
C                      array C.
C             MODE=1 - A Cholesky decomposition to get the first
C                      unconstrained minimizer, is computed internally.
C   IOUT :    Integer indicating the desired output unit number, i.e. all
C             write-statements start with 'WRITE(IOUT,... '.
C   IFAIL :   The parameter shows the reason for terminating a solution
C             process. On return, IFAIL could get the following values:
C             IFAIL=0  : The optimality conditions are satisfied.
C             IFAIL=1  : The algorithm has been stopped after too many
C                        MAXIT iterations (40*(N+M)).
C             IFAIL=2  : Termination accuracy insufficient to satisfy
C                        convergence criterion.
C             IFAIL=3  : Internal inconsistency of QL, division by zero.
C             IFAIL=4  : Numerical instability prevents successful termination.
C                        Use tolerance specified in WAR(1) for a restart.
C             IFAIL=5  : Length of a working array is too short.
C             IFAIL>100: Constraints are inconsistent and IFAIL=100+ICON,
C                        where ICON denotes a constraint causing the conflict.
C   IPRINT :  Specification of the desired output level.
C             IPRINT=0 :  No output of the program.
C             IPRINT=1 :  Only a final error message is given.
C   WAR(LWAR),LWAR : WAR is a real working array of length LWAR. LWAR
C             must be at least 3*NMAX*NMAX/2 + 10*NMAX + MMAX + M + 1.
C   IWAR(LIWAR),LIWAR : The user has to provide working space for an
C             integer array. LIWAR must be at least N.
C
C
C
C   Copyright(C):  Klaus Schittkowski, Department of Computer Science,
C                  University of Bayreuth, D-95440 Bayreuth, Germany,
C                  (1987-2010)
C
C
C
C   Reference:     M.J.D. Powell: ZQPCVX, A FORTRAN Subroutine for Convex
C                  Programming, Report DAMTP/1983/NA17, University of
C                  Cambridge, England, 1983
C
C                  D. Goldfarb, A. Idnani (1983): A numerically stable
C                  method for solving strictly convex quadratic programs,
C                  Mathematical Programming, Vol. 27, 1-33
C
C                  K. Schittkowski (2007): QL: A Fortran code for convex
C                  quadratic programming - user's guide, Report, Department
C                  of Computer Science, University of Bayreuth
C
C
C
C   Version:       1.0  (Mar, 1987) - first implementation
C                  1.8  (Oct, 2002) - new tolerances
C                  2.0  (Apr, 2003) - parameter list, documentation
C                  2.1  (Sep, 2004) - new error message
C                  2.11 (Jul, 2005) - error message (LWAR)
C                  2.12 (Jul, 2007) - parameter declarations
C                  2.13 (Sep, 2007) - test for division by zero
C                  2.14 (Feb, 2009) - some if-statements changed
C                  2.15 (May, 2009) - comments
C                  2.16 (Jun, 2009) - IFAIL=4 introduced
C                  2.17 (Apr, 2010) - comments
C                  2.2  (Sep, 2010) - division by zero
C
C*********************************************************************
C
      IMPLICIT NONE
      INTEGER NMAX,MMAX,N,MNN,LWAR,LIWAR
      DIMENSION C(NMAX,N),D(N),A(MMAX,N),B(MMAX),
     /      XL(N),XU(N),X(N),U(MNN),WAR(LWAR),IWAR(LIWAR)
      DOUBLE PRECISION C,D,A,B,X,XL,XU,U,WAR,DIAG,ZERO,
     /      EPS,QPEPS
      INTEGER M,ME,IOUT,MODE,IFAIL,IPRINT,IWAR,INW1,INW2,IN,J,LW,MN,I,
     /      IDIAG,INFO,NACT,MAXIT
      LOGICAL LQL
      INTRINSIC INT
      EXTERNAL QL0002
C
C     CONSTANT DATA
C
      LQL=.FALSE.
      IF (MODE.EQ.1) LQL=.TRUE.
      ZERO=0.0D+0
      MAXIT=40*(M+N)
      QPEPS=EPS
      INW1=1
      INW2=INW1+MMAX
C
C     PREPARE PROBLEM DATA FOR EXECUTION
C
      IF (M.GT.0) THEN
         IN=INW1
         DO J=1,M
            WAR(IN)=-B(J)
            IN=IN+1
         ENDDO
      ENDIF
      LW=3*NMAX*NMAX/2 + 10*NMAX + M
      IF ((INW2+LW).GT.LWAR) GOTO 80
      IF (LIWAR.LT.N) GOTO 81
      IF (MNN.LT.M+N+N) GOTO 82
      MN=M+N
C
C     CALL OF QL0002
C
      CALL QL0002(N,M,ME,MMAX,MN,NMAX,LQL,A,WAR(INW1),
     /    D,C,XL,XU,X,NACT,IWAR,MAXIT,QPEPS,INFO,DIAG,
     /    WAR(INW2),LW)
C
C     TEST OF MATRIX CORRECTIONS
C
      IF ((INFO.EQ.3).OR.(INFO.EQ.4)) THEN
         DO I=1,N
            X(I) = 0.0D0
         ENDDO
      ENDIF
      IFAIL=0
      IF (INFO.EQ.1) GOTO 40
      IF (INFO.EQ.2) GOTO 90
      IF (INFO.EQ.3) GOTO 83
      IF (INFO.EQ.4) GOTO 95
      IDIAG=0
      IF ((DIAG.GT.ZERO).AND.(DIAG.LT.1000.0D0)) IDIAG=INT(DIAG)
      IF ((IPRINT.GT.0).AND.(IDIAG.GT.0))
     /   WRITE(IOUT,1000) IDIAG
      IF (INFO .LT. 0) GOTO 70
C
C     REORDER MULTIPLIER
C
      DO  50 J=1,MNN
   50 U(J)=ZERO
      IN=INW2-1
      IF (NACT.EQ.0) GOTO 30
      DO  60 I=1,NACT
      J=IWAR(I)
      U(J)=WAR(IN+I)
   60 CONTINUE
   30 CONTINUE
      RETURN
C
C     ERROR MESSAGES
C
   70 IFAIL=-INFO+100
      IF ((IPRINT.GT.0).AND.(NACT.GT.0))
     /     WRITE(IOUT,1100) -INFO,(IWAR(I),I=1,NACT)
      RETURN
   80 IFAIL=5
      IF (IPRINT .GT. 0) WRITE(IOUT,1200)INW2+LW,LWAR
      RETURN
   81 IFAIL=5
      IF (IPRINT .GT. 0) WRITE(IOUT,1210)
      RETURN
   82 IFAIL=5
      IF (IPRINT .GT. 0) WRITE(IOUT,1220)
      RETURN
   83 IFAIL=3
      IF (IPRINT .GT. 0) WRITE(IOUT,1230)
      RETURN
   40 IFAIL=1
      IF (IPRINT.GT.0) WRITE(IOUT,1300) MAXIT
      RETURN
   90 IFAIL=2
      IF (IPRINT.GT.0) WRITE(IOUT,1400)
      RETURN
   95 IFAIL=4
      IF (IPRINT.GT.0) WRITE(IOUT,1500) WAR(1)
      RETURN
C
C     FORMAT-INSTRUCTIONS
C
 1000 FORMAT(/8X,'*** ERROR (QL): Matrix G was enlarged',I3,
     /        '-times by unit matrix!')
 1100 FORMAT(/8X,'*** ERROR (QL): Constraint ',I5,
     /        ' not consistent to ',/,(10X,10I5))
 1200 FORMAT(/8X,'*** ERROR (QL): LWAR too small! Should be at least ',
     /      I8,', but only ',I8,' is available.')
 1210 FORMAT(/8X,'*** ERROR (QL): LIWAR too small!')
 1220 FORMAT(/8X,'*** ERROR (QL): MNN too small!')
 1230 FORMAT(/8X,'*** ERROR (QL): Internal error, division by zero!')
 1300 FORMAT(/8X,'*** ERROR (QL): Too many iterations (more than',I6,
     /           ')')
 1400 FORMAT(/8X,'*** ERROR (QL): Accuracy insufficient to attain ',
     /           'convergence!')
 1500 FORMAT(/8X,'*** ERROR (QL): Accuracy too small to detect ',
     /           'feasibility! Restart with tolerance ',d12.4,
     /           ' in WA(1)!')
      END
C
      SUBROUTINE QL0002(N,M,MEQ,MMAX,MN,NMAX,LQL,A,B,GRAD,G,
     /      XL,XU,X,NACT,IACT,MAXIT,VSMALL,INFO,DIAG,W,LW)
C
C**************************************************************************
C
C
C   THIS SUBROUTINE SOLVES THE QUADRATIC PROGRAMMING PROBLEM
C
C       MINIMIZE      GRAD'*X  +  0.5 * X*G*X
C       SUBJECT TO    A(K)*X  =  B(K)   K=1,2,...,MEQ,
C                     A(K)*X >=  B(K)   K=MEQ+1,...,M,
C                     XL  <=  X  <=  XU
C
C   THE QUADRATIC PROGRAMMING METHOD PROCEEDS FROM AN INITIAL CHOLESKY-
C   DECOMPOSITION OF THE OBJECTIVE FUNCTION MATRIX, TO CALCULATE THE
C   UNIQUELY DETERMINED MINIMIZER OF THE UNCONSTRAINED PROBLEM.
C   SUCCESSIVELY ALL VIOLATED CONSTRAINTS ARE ADDED TO A WORKING SET
C   AND A MINIMIZER OF THE OBJECTIVE FUNCTION SUBJECT TO ALL CONSTRAINTS
C   IN THIS WORKING SET IS COMPUTED. IT IS POSSIBLE THAT CONSTRAINTS
C   HAVE TO LEAVE THE WORKING SET.
C
C
C   DESCRIPTION OF PARAMETERS:
C
C     N        : IS THE NUMBER OF VARIABLES.
C     M        : TOTAL NUMBER OF CONSTRAINTS.
C     MEQ      : NUMBER OF EQUALITY CONTRAINTS.
C     MMAX     : ROW DIMENSION OF A, DIMENSION OF B. MMAX MUST BE AT
C                LEAST ONE AND GREATER OR EQUAL TO M.
C     MN       : MUST BE EQUAL M + N.
C     NMAX     : ROW DIEMSION OF G. MUST BE AT LEAST N.
C     LQL      : DETERMINES INITIAL DECOMPOSITION.
C        LQL = .FALSE.  : THE UPPER TRIANGULAR PART OF THE MATRIX G
C                         CONTAINS INITIALLY THE CHOLESKY-FACTOR OF A SUITABLE
C                         DECOMPOSITION.
C        LQL = .TRUE.   : THE INITIAL CHOLESKY-FACTORISATION OF G IS TO BE
C                         PERFORMED BY THE ALGORITHM.
C     A(MMAX,NMAX) : A IS A MATRIX WHOSE COLUMNS ARE THE CONSTRAINTS NORMALS.
C     B(MMAX)  : CONTAINS THE RIGHT HAND SIDES OF THE CONSTRAINTS.
C     GRAD(N)  : CONTAINS THE OBJECTIVE FUNCTION VECTOR GRAD.
C     G(NMAX,N): CONTAINS THE SYMMETRIC OBJECTIVE FUNCTION MATRIX.
C     XL(N), XU(N): CONTAIN THE LOWER AND UPPER BOUNDS FOR X.
C     X(N)     : VECTOR OF VARIABLES.
C     NACT     : FINAL NUMBER OF ACTIVE CONSTRAINTS.
C     IACT(K) (K=1,2,...,NACT): INDICES OF THE FINAL ACTIVE CONSTRAINTS.
C     INFO     : REASON FOR THE RETURN FROM THE SUBROUTINE.
C         INFO = 0 : CALCULATION WAS TERMINATED SUCCESSFULLY.
C         INFO = 1 : MAXIMUM NUMBER OF ITERATIONS ATTAINED.
C         INFO = 2 : ACCURACY IS INSUFFICIENT TO MAINTAIN INCREASING
C                    FUNCTION VALUES.
C         INFO = 3 : INTERNAL INCONSISTENCY OF QP, DIVISION BY ZERO.
C         INFO = 4 : ACCURACY TOO SMALL FOR SUCESSFUL TERMINATION.
C         INFO < 0 : THE CONSTRAINT WITH INDEX ABS(INFO) AND THE CON-
C                    STRAINTS WHOSE INDICES ARE IACT(K), K=1,2,...,NACT,
C                    ARE INCONSISTENT.
C     MAXIT    : MAXIMUM NUMBER OF ITERATIONS.
C     VSMALL   : REQUIRED ACCURACY TO BE ACHIEVED (E.G. IN THE ORDER OF THE
C                MACHINE PRECISION FOR SMALL AND WELL-CONDITIONED PROBLEMS).
C     DIAG     : ON RETURN DIAG IS EQUAL TO THE MULTIPLE OF THE UNIT MATRIX
C                THAT WAS ADDED TO G TO ACHIEVE POSITIVE DEFINITENESS.
C     W(LW)    : THE ELEMENTS OF W(.) ARE USED FOR WORKING SPACE. THE LENGTH
C                OF W MUST NOT BE LESS THAN (1.5*NMAX*NMAX + 10*NMAX + M).
C                WHEN INFO = 0 ON RETURN, THE LAGRANGE MULTIPLIERS OF THE
C                FINAL ACTIVE CONSTRAINTS ARE HELD IN W(K), K=1,2,...,NACT.
C   THE VALUES OF N, M, MEQ, MMAX, MN, AND NMAX AND THE ELEMENTS OF
C   A, B, GRAD AND G ARE NOT ALTERED.
C
C   THE FOLLOWING INTEGERS ARE USED TO PARTITION W:
C     THE FIRST N ELEMENTS OF W HOLD LAGRANGE MULTIPLIER ESTIMATES.
C     W(IWZ+I+(N-1)*J) HOLDS THE MATRIX ELEMENT Z(I,J).
C     W(IWR+I+0.5*J*(J-1)) HOLDS THE UPPER TRIANGULAR MATRIX
C       ELEMENT R(I,J). THE SUBSEQUENT N COMPONENTS OF W MAY BE
C       TREATED AS AN EXTRA COLUMN OF R(.,.).
C     W(IWW-N+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE.
C     W(IWW+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE.
C     W(IWD+I) (I=1,2,...,N) HOLDS G(I,I) DURING THE CALCULATION.
C     W(IWX+I) (I=1,2,...,N) HOLDS VARIABLES THAT WILL BE USED TO
C       TEST THAT THE ITERATIONS INCREASE THE OBJECTIVE FUNCTION.
C     W(IWA+K) (K=1,2,...,M) USUALLY HOLDS THE RECIPROCAL OF THE
C       LENGTH OF THE K-TH CONSTRAINT, BUT ITS SIGN INDICATES
C       WHETHER THE CONSTRAINT IS ACTIVE.
C
C
C   AUTHOR:    K. SCHITTKOWSKI,
C              MATHEMATISCHES INSTITUT,
C              UNIVERSITAET BAYREUTH,
C              8580 BAYREUTH,
C              GERMANY, F.R.
C
C   AUTHOR OF ORIGINAL VERSION:
C              M.J.D. POWELL, DAMTP,
C              UNIVERSITY OF CAMBRIDGE, SILVER STREET
C              CAMBRIDGE,
C              ENGLAND
C
C
C   REFERENCE: M.J.D. POWELL: ZQPCVX, A FORTRAN SUBROUTINE FOR CONVEX
C              PROGRAMMING, REPORT DAMTP/1983/NA17, UNIVERSITY OF
C              CAMBRIDGE, ENGLAND, 1983.
C
C
C   VERSION :  2.0 (MARCH, 1987)
C
C
C*************************************************************************
C
      IMPLICIT NONE
      INTEGER   MMAX,NMAX,N,LW,NFLAG,IWWN
      DIMENSION A(MMAX,N),B(MMAX),GRAD(N),G(NMAX,N),X(N),IACT(N),
     /          W(LW),XL(N),XU(N)
      INTEGER   M,MEQ,MN,NACT,IACT,INFO,MAXIT
      DOUBLE PRECISION CVMAX,DIAG,DIAGR,FDIFF,FDIFFA,GA,GB,PARINC,
     /          PARNEW,RATIO,RES,STEP,SUM,SUMX,SUMY,SUMA,SUMB,SUMC,
     /          TEMP,TEMPA,VSMALL,XMAG,XMAGR,ZERO,ONE,TWO,ONHA,VFACT,
     /          MINCV
      DOUBLE PRECISION A,B,G,GRAD,W,X,XL,XU
      DOUBLE PRECISION DMAX1,DSQRT,DABS,DMIN1
      INTEGER   MAX0,MIN0
      INTRINSIC DMAX1,DSQRT,DABS,DMIN1,MAX0,MIN0
      INTEGER   IWZ,IWR,IWW,IWD,IWA,IFINC,KFINC,I,IA,ID,II,IR,IRA,K,
     /          IRB,J,NM,IZ,IZA,ITERC,ITREF,JFINC,IFLAG,IWS,IS,K1,IW,
     /          KK,IL,IU,JU,KFLAG,LFLAG,JFLAG,KDROP,NU,MFLAG,
     /          KNEXT,IX,IWX,IWY,IY,JL
      LOGICAL   LQL,LOWER
C
C	INITIALIZE VARIABLES THAT MAY BE UNINITIALIZED OTHERWISE
C
	NFLAG  = 0
	PARINC = 0.0D0
	PARNEW = 0.0D0
	RATIO  = 0.0D0
	RES    = 0.0D0
	STEP   = 0.0D0
	SUMY   = 0.0D0
	TEMP   = 0.0D0
	J      = 0
	JFLAG  = 0
	KDROP  = 0
	NU     = 0
	MFLAG  = 0
	KNEXT  = 0
C
C   INITIAL ADDRESSES
C
      IWZ=NMAX
      IWR=IWZ+NMAX*NMAX
      IWW=IWR+(NMAX*(NMAX+3))/2
      IWD=IWW+NMAX
      IWX=IWD+NMAX
      IWA=IWX+NMAX
C
C     SET SOME CONSTANTS.
C
      ZERO=0.D+0
      ONE=1.D+0
      TWO=2.D+0
      ONHA=1.5D+0
      VFACT=1.D+0
      MINCV=1.D30
C
C     SET SOME PARAMETERS.
C     NUMBER LESS THAN VSMALL ARE ASSUMED TO BE NEGLIGIBLE.
C     THE MULTIPLE OF I THAT IS ADDED TO G IS AT MOST DIAGR TIMES
C       THE LEAST MULTIPLE OF I THAT GIVES POSITIVE DEFINITENESS.
C     X IS RE-INITIALISED IF ITS MAGNITUDE IS REDUCED BY THE
C       FACTOR XMAGR.
C     A CHECK IS MADE FOR AN INCREASE IN F EVERY IFINC ITERATIONS,
C       AFTER KFINC ITERATIONS ARE COMPLETED.
C
      DIAGR=TWO
      DIAG=ZERO
      XMAGR=1.0D-2
      IFINC=3
      KFINC=MAX0(10,N)
C
C     FIND THE RECIPROCALS OF THE LENGTHS OF THE CONSTRAINT NORMALS.
C     RETURN IF A CONSTRAINT IS INFEASIBLE DUE TO A ZERO NORMAL.
C
      NACT=0
      IF (M .LE. 0) GOTO 45
      DO 40 K=1,M
      SUM=ZERO
      DO I=1,N
         SUM=SUM+A(K,I)**2
      ENDDO
      IF (SUM .GT. ZERO) GOTO 20
      IF (B(K) .EQ. ZERO) GOTO 30
      INFO=-K
      IF (K .LE. MEQ) GOTO 730
c      IF (B(K)) 30,30,730
      IF (B(K) .LE. ZERO) THEN
         GOTO 30
      ELSE
         GOTO 730
      ENDIF
   20 SUM=ONE/DSQRT(SUM)
   30 IA=IWA+K
      W(IA)=SUM
   40 CONTINUE
   45 DO K=1,N
         IA=IWA+M+K
         W(IA)=ONE
      ENDDO
C
C     IF NECESSARY INCREASE THE DIAGONAL ELEMENTS OF G.
C
      IF (.NOT. LQL) GOTO 165
      DO 60 I=1,N
      ID=IWD+I
      W(ID)=G(I,I)
      DIAG=DMAX1(DIAG,VSMALL-W(ID))
      IF (I .EQ. N) GOTO 60
      II=I+1
      DO J=II,N
         GA=-DMIN1(W(ID),G(J,J))
         GB=DABS(W(ID)-G(J,J))+DABS(G(I,J))
         IF (GB .GT. ZERO) GA=GA+G(I,J)**2/GB
         DIAG=DMAX1(DIAG,GA)
      ENDDO
   60 CONTINUE
      IF (DIAG .LE. ZERO) GOTO 90
   70 DIAG=DIAGR*DIAG
      DO I=1,N
         ID=IWD+I
         G(I,I)=DIAG+W(ID)
      ENDDO
C
C     FORM THE CHOLESKY FACTORISATION OF G. THE TRANSPOSE
C     OF THE FACTOR WILL BE PLACED IN THE R-PARTITION OF W.
C
   90 IR=IWR
      DO 130 J=1,N
      IRA=IWR
      IRB=IR+1
      DO 120 I=1,J
      TEMP=G(I,J)
      IF (I .EQ. 1) GOTO 110
      DO 100 K=IRB,IR
         IRA=IRA+1
         TEMP=TEMP-W(K)*W(IRA)
  100 CONTINUE
  110 IR=IR+1
      IRA=IRA+1
      IF (I .LT. J) W(IR)=TEMP/W(IRA)
  120 CONTINUE
      IF (TEMP .LT. VSMALL) GOTO 140
      W(IR)=DSQRT(TEMP)
  130 CONTINUE
      GOTO 170
C
C     INCREASE FURTHER THE DIAGONAL ELEMENT OF G.
C
  140 W(J)=ONE
      SUMX=ONE
      K=J
  150 SUM=ZERO
      IRA=IR-1
      DO I=K,J
         SUM=SUM-W(IRA)*W(I)
         IRA=IRA+I
      ENDDO
      IR=IR-K
      K=K-1
      IF (K.LT.1) GOTO 165
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      IF (W(IR).NE.0.0D0) THEN
         W(K)=SUM/W(IR)
      ELSE
         W(K)=1.0D30
      ENDIF
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      SUMX=SUMX+W(K)**2
      IF (K .GE. 2) GOTO 150
      DIAG=DIAG+VSMALL-TEMP/SUMX
      GOTO 70
C
C     STORE THE CHOLESKY FACTORISATION IN THE R-PARTITION
C     OF W.
C
  165 CONTINUE
      IR=IWR
      DO I=1,N
         DO J=1,I
            IR=IR+1
            W(IR)=G(J,I)
         ENDDO
      ENDDO
C
C     SET Z THE INVERSE OF THE MATRIX IN R.
C
  170 NM=N-1
      DO 220 I=1,N
      IZ=IWZ+I
      IF (I .GT. 1) THEN
         DO J=2,I
            W(IZ)=ZERO
            IZ=IZ+N
         ENDDO
      ENDIF
      IR=IWR+(I+I*I)/2
      W(IZ)=ONE/W(IR)
      IF (I .EQ. N) GOTO 220
      IZA=IZ
      DO 210 J=I,NM
      IR=IR+I
      SUM=ZERO
      DO K=IZA,IZ,N
         SUM=SUM+W(K)*W(IR)
         IR=IR+1
      ENDDO
      IZ=IZ+N
  210 W(IZ)=-SUM/W(IR)
  220 CONTINUE
C
C     SET THE INITIAL VALUES OF SOME VARIABLES.
C     ITERC COUNTS THE NUMBER OF ITERATIONS.
C     ITREF IS SET TO ONE WHEN ITERATIVE REFINEMENT IS REQUIRED.
C     JFINC INDICATES WHEN TO TEST FOR AN INCREASE IN F.
C
      ITERC=1
      ITREF=0
      JFINC=-KFINC
C
C     SET X TO ZERO AND SET THE CORRESPONDING RESIDUALS OF THE
C     KUHN-TUCKER CONDITIONS.
C
  230 IFLAG=1
      IWS=IWW-N
      DO 240 I=1,N
      X(I)=ZERO
      IW=IWW+I
      W(IW)=GRAD(I)
      IF (I .GT. NACT) GOTO 240
      W(I)=ZERO
      IS=IWS+I
      K=IACT(I)
      IF (K .LE. M) GOTO 235
      IF (K .GT. MN) GOTO 234
      K1=K-M
      W(IS)=XL(K1)
      GOTO 240
  234 K1=K-MN
      W(IS)=-XU(K1)
      GOTO 240
  235 W(IS)=B(K)
  240 CONTINUE
      XMAG=ZERO
      VFACT=1.D+0
C      IF (NACT) 340,340,280
      IF (NACT .LE. 0) THEN
         GOTO 340
      ELSE
         GOTO 280
      ENDIF
C
C     SET THE RESIDUALS OF THE KUHN-TUCKER CONDITIONS FOR GENERAL X.
C
  250 IFLAG=2
      IWS=IWW-N
      DO 260 I=1,N
      IW=IWW+I
      W(IW)=GRAD(I)
      IF (LQL) GOTO 259
      ID=IWD+I
      W(ID)=ZERO
      DO 251 J=I,N
  251 W(ID)=W(ID)+G(I,J)*X(J)
      DO 252 J=1,I
      ID=IWD+J
  252 W(IW)=W(IW)+G(J,I)*W(ID)
      GOTO 260
  259 DO 261 J=1,N
  261 W(IW)=W(IW)+G(I,J)*X(J)
  260 CONTINUE
      IF (NACT .EQ. 0) GOTO 340
      DO 270 K=1,NACT
      KK=IACT(K)
      IS=IWS+K
      IF (KK .GT. M) GOTO 265
      W(IS)=B(KK)
      DO 264 I=1,N
      IW=IWW+I
      W(IW)=W(IW)-W(K)*A(KK,I)
  264 W(IS)=W(IS)-X(I)*A(KK,I)
      GOTO 270
  265 IF (KK .GT. MN) GOTO 266
      K1=KK-M
      IW=IWW+K1
      W(IW)=W(IW)-W(K)
      W(IS)=XL(K1)-X(K1)
      GOTO 270
  266 K1=KK-MN
      IW=IWW+K1
      W(IW)=W(IW)+W(K)
      W(IS)=-XU(K1)+X(K1)
  270 CONTINUE
C
C     PRE-MULTIPLY THE VECTOR IN THE S-PARTITION OF W BY THE
C     INVERS OF R TRANSPOSE.
C
  280 IR=IWR
C      IP=IWW+1
C      IPP=IWW+N
      IL=IWS+1
      IU=IWS+NACT
      DO 310 I=IL,IU
      SUM=ZERO
      IF (I .EQ. IL) GOTO 300
      JU=I-1
      DO 290 J=IL,JU
      IR=IR+1
  290 SUM=SUM+W(IR)*W(J)
  300 IR=IR+1
  310 W(I)=(W(I)-SUM)/W(IR)
C
C     SHIFT X TO SATISFY THE ACTIVE CONSTRAINTS AND MAKE THE
C     CORRESPONDING CHANGE TO THE GRADIENT RESIDUALS.
C
      DO 330 I=1,N
      IZ=IWZ+I
      SUM=ZERO
      DO 320 J=IL,IU
      SUM=SUM+W(J)*W(IZ)
  320 IZ=IZ+N
      X(I)=X(I)+SUM
      IF (LQL) GOTO 329
      ID=IWD+I
      W(ID)=ZERO
      DO 321 J=I,N
  321 W(ID)=W(ID)+G(I,J)*SUM
      IW=IWW+I
      DO 322 J=1,I
      ID=IWD+J
  322 W(IW)=W(IW)+G(J,I)*W(ID)
      GOTO 330
  329 DO 331 J=1,N
      IW=IWW+J
  331 W(IW)=W(IW)+SUM*G(I,J)
  330 CONTINUE
C
C     FORM THE SCALAR PRODUCT OF THE CURRENT GRADIENT RESIDUALS
C     WITH EACH COLUMN OF Z.
C
  340 KFLAG=1
      GOTO 930
  350 IF (NACT .EQ. N) GOTO 380
C
C     SHIFT X SO THAT IT SATISFIES THE REMAINING KUHN-TUCKER
C     CONDITIONS.
C
      IL=IWS+NACT+1
      IZA=IWZ+NACT*N
      DO 370 I=1,N
      SUM=ZERO
      IZ=IZA+I
      DO 360 J=IL,IWW
      SUM=SUM+W(IZ)*W(J)
  360 IZ=IZ+N
  370 X(I)=X(I)-SUM
      INFO=0
      IF (NACT .EQ. 0) GOTO 410
C
C     UPDATE THE LAGRANGE MULTIPLIERS.
C
  380 LFLAG=3
      GOTO 740
  390 DO 400 K=1,NACT
      IW=IWW+K
  400 W(K)=W(K)+W(IW)

C
C     REVISE THE VALUES OF XMAG.
C     BRANCH IF ITERATIVE REFINEMENT IS REQUIRED.
C
  410 JFLAG=1
      GOTO 910
  420 IF (IFLAG .EQ. ITREF) GOTO 250
C
C     DELETE A CONSTRAINT IF A LAGRANGE MULTIPLIER OF AN
C     INEQUALITY CONSTRAINT IS NEGATIVE.
C
      KDROP=0
      GOTO 440
  430 KDROP=KDROP+1
      IF (W(KDROP) .GE. ZERO) GOTO 440
      IF (IACT(KDROP) .LE. MEQ) GOTO 440
      NU=NACT
      MFLAG=1
      GOTO 800
  440 IF (KDROP .LT. NACT) GOTO 430
C
C     SEEK THE GREATEAST NORMALISED CONSTRAINT VIOLATION, DISREGARDING
C     ANY THAT MAY BE DUE TO COMPUTER ROUNDING ERRORS.
C
  450 CVMAX=ZERO
      IF (M .LE. 0) GOTO 481
      DO 480 K=1,M
      IA=IWA+K
      IF (W(IA) .LE. ZERO) GOTO 480
      SUM=-B(K)
      DO 460 I=1,N
  460 SUM=SUM+X(I)*A(K,I)
      SUMX=-SUM*W(IA)
      IF (K .LE. MEQ) SUMX=DABS(SUMX)
      IF (SUMX .LE. CVMAX) GOTO 480
      TEMP=DABS(B(K))
      DO 470 I=1,N
  470 TEMP=TEMP+DABS(X(I)*A(K,I))
      TEMPA=TEMP+DABS(SUM)
      IF (TEMPA .LE. TEMP) GOTO 480
      TEMP=TEMP+ONHA*DABS(SUM)
      IF (TEMP .LE. TEMPA) GOTO 480
      CVMAX=SUMX
      RES=SUM
      KNEXT=K

  480 CONTINUE
  481 DO 485 K=1,N
      LOWER=.TRUE.
      IA=IWA+M+K
      IF (W(IA) .LE. ZERO) GOTO 485
      SUM=XL(K)-X(K)
C      IF (SUM) 482,485,483
      IF (SUM .LT. ZERO) THEN
         GOTO 482
      ELSE
         IF (SUM .EQ. ZERO) THEN
            GOTO 485
         ELSE
            GOTO 483
         ENDIF
      ENDIF
  482 SUM=X(K)-XU(K)
      LOWER=.FALSE.
  483 IF (SUM .LE. CVMAX) GOTO 485
      CVMAX=SUM
      RES=-SUM
      KNEXT=K+M
      IF (LOWER) GOTO 485
      KNEXT=K+MN
  485 CONTINUE
      IF (CVMAX.LT.MINCV) MINCV=CVMAX
C
C     TEST FOR CONVERGENCE
C
      INFO=0
      IF (CVMAX .LE. VSMALL) GOTO 700
C
C     RETURN IF, DUE TO ROUNDING ERRORS, THE ACTUAL CHANGE IN
C     X MAY NOT INCREASE THE OBJECTIVE FUNCTION
C
      JFINC=JFINC+1
      IF (JFINC .EQ. 0) GOTO 510
      IF (JFINC .NE. IFINC) GOTO 530
      FDIFF=ZERO
      FDIFFA=ZERO
      DO 500 I=1,N
      SUM=TWO*GRAD(I)
      SUMX=DABS(SUM)
      IF (LQL) GOTO 489
      ID=IWD+I
      W(ID)=ZERO
      DO 486 J=I,N
      IX=IWX+J
  486 W(ID)=W(ID)+G(I,J)*(W(IX)+X(J))
      DO 487 J=1,I
      ID=IWD+J
      TEMP=G(J,I)*W(ID)
      SUM=SUM+TEMP
  487 SUMX=SUMX+DABS(TEMP)
      GOTO 495
  489 DO 490 J=1,N
      IX=IWX+J
      TEMP=G(I,J)*(W(IX)+X(J))
      SUM=SUM+TEMP
  490 SUMX=SUMX+DABS(TEMP)
  495 IX=IWX+I
      FDIFF=FDIFF+SUM*(X(I)-W(IX))
  500 FDIFFA=FDIFFA+SUMX*DABS(X(I)-W(IX))
      INFO=2
      SUM=FDIFFA+FDIFF
      IF (SUM .LE. FDIFFA) GOTO 700
      TEMP=FDIFFA+ONHA*FDIFF
      IF (TEMP .LE. SUM) GOTO 700
      JFINC=0
      INFO=0
  510 DO 520 I=1,N
      IX=IWX+I
  520 W(IX)=X(I)
C
C     FORM THE SCALAR PRODUCT OF THE NEW CONSTRAINT NORMAL WITH EACH
C     COLUMN OF Z. PARNEW WILL BECOME THE LAGRANGE MULTIPLIER OF
C     THE NEW CONSTRAINT.
C
  530 ITERC=ITERC+1
      IF (ITERC.LE.MAXIT) GOTO 531
      INFO=1
      GOTO 710
  531 CONTINUE
      IWS=IWR+(NACT+NACT*NACT)/2
      IF (KNEXT .GT. M) GOTO 541
      DO 540 I=1,N
      IW=IWW+I
  540 W(IW)=A(KNEXT,I)
      GOTO 549
  541 DO 542 I=1,N
      IW=IWW+I
  542 W(IW)=ZERO
      K1=KNEXT-M
      IF (K1 .GT. N) GOTO 545
      IW=IWW+K1
      W(IW)=ONE
      IZ=IWZ+K1
      DO 543 I=1,N
      IS=IWS+I
      W(IS)=W(IZ)
  543 IZ=IZ+N
      GOTO 550
  545 K1=KNEXT-MN
      IW=IWW+K1
      W(IW)=-ONE
      IZ=IWZ+K1
      DO 546 I=1,N
      IS=IWS+I
      W(IS)=-W(IZ)
  546 IZ=IZ+N
      GOTO 550
  549 KFLAG=2
      GOTO 930
  550 PARNEW=ZERO
C
C     APPLY GIVENS ROTATIONS TO MAKE THE LAST (N-NACT-2) SCALAR
C     PRODUCTS EQUAL TO ZERO.
C
      IF (NACT .EQ. N) GOTO 570
      NU=N
      NFLAG=1
      GOTO 860
C
C     BRANCH IF THERE IS NO NEED TO DELETE A CONSTRAINT.
C
  560 IS=IWS+NACT
      IF (NACT .EQ. 0) GOTO 640
      SUMA=ZERO
      SUMB=ZERO
      SUMC=ZERO
      IZ=IWZ+NACT*N
      DO 563 I=1,N
      IZ=IZ+1
      IW=IWW+I
      SUMA=SUMA+W(IW)*W(IZ)
      SUMB=SUMB+DABS(W(IW)*W(IZ))
  563 SUMC=SUMC+W(IZ)**2
      TEMP=SUMB+.1D+0*DABS(SUMA)
      TEMPA=SUMB+.2D+0*DABS(SUMA)
      IF (TEMP .LE. SUMB) GOTO 570
      IF (TEMPA .LE. TEMP) GOTO 570
      IF (SUMB .GT. VSMALL) GOTO 5
      GOTO 570
    5 SUMC=DSQRT(SUMC)
      IA=IWA+KNEXT
      IF (KNEXT .LE. M) SUMC=SUMC/W(IA)
      TEMP=SUMC+.1D+0*DABS(SUMA)
      TEMPA=SUMC+.2D+0*DABS(SUMA)
      IF (TEMP .LE. SUMC) GOTO 567
      IF (TEMPA .LE. TEMP) GOTO 567
      GOTO 640
C
C     CALCULATE THE MULTIPLIERS FOR THE NEW CONSTRAINT NORMAL
C     EXPRESSED IN TERMS OF THE ACTIVE CONSTRAINT NORMALS.
C     THEN WORK OUT WHICH CONTRAINT TO DROP.
C
  567 LFLAG=4
      GOTO 740
  570 LFLAG=1
      GOTO 740
C
C     COMPLETE THE TEST FOR LINEARLY DEPENDENT CONSTRAINTS.
C
  571 IF (KNEXT .GT. M) GOTO 574
      DO 573 I=1,N
      SUMA=A(KNEXT,I)
      SUMB=DABS(SUMA)
      IF (NACT.EQ.0) GOTO 581
      DO 572 K=1,NACT
      KK=IACT(K)
      IF (KK.LE.M) GOTO 568
      KK=KK-M
      TEMP=ZERO
      IF (KK.EQ.I) TEMP=W(IWW+KK)
      KK=KK-N
      IF (KK.EQ.I) TEMP=-W(IWW+KK)
      GOTO 569
  568 CONTINUE
      IW=IWW+K
      TEMP=W(IW)*A(KK,I)
  569 CONTINUE
      SUMA=SUMA-TEMP
  572 SUMB=SUMB+DABS(TEMP)
  581 IF (SUMA .LE. VSMALL) GOTO 573
      TEMP=SUMB+.1D+0*DABS(SUMA)
      TEMPA=SUMB+.2D+0*DABS(SUMA)
      IF (TEMP .LE. SUMB) GOTO 573
      IF (TEMPA .LE. TEMP) GOTO 573
      GOTO 630
  573 CONTINUE
      LFLAG=1
      GOTO 775
  574 K1=KNEXT-M
      IF (K1 .GT. N) K1=K1-N
      DO 578 I=1,N
      SUMA=ZERO
      IF (I .NE. K1) GOTO 575
      SUMA=ONE
      IF (KNEXT .GT. MN) SUMA=-ONE
  575 SUMB=DABS(SUMA)
      IF (NACT.EQ.0) GOTO 582
      DO 577 K=1,NACT
      KK=IACT(K)
      IF (KK .LE. M) GOTO 579
      KK=KK-M
      TEMP=ZERO
      IF (KK.EQ.I) TEMP=W(IWW+KK)
      KK=KK-N
      IF (KK.EQ.I) TEMP=-W(IWW+KK)
      GOTO 576
  579 IW=IWW+K
      TEMP=W(IW)*A(KK,I)
  576 SUMA=SUMA-TEMP
  577 SUMB=SUMB+DABS(TEMP)
  582 TEMP=SUMB+.1D+0*DABS(SUMA)
      TEMPA=SUMB+.2D+0*DABS(SUMA)
      IF (TEMP .LE. SUMB) GOTO 578
      IF (TEMPA .LE. TEMP) GOTO 578
      GOTO 630
  578 CONTINUE
      LFLAG=1
      GOTO 775
C
C     BRANCH IF THE CONTRAINTS ARE INCONSISTENT.
C
  580 INFO=-KNEXT
      IF (KDROP .EQ. 0) GOTO 700
      PARINC=RATIO
      PARNEW=PARINC
C
C     REVISE THE LAGRANGE MULTIPLIERS OF THE ACTIVE CONSTRAINTS.
C
  590 IF (NACT.EQ.0) GOTO 601
      DO 600 K=1,NACT
      IW=IWW+K
      W(K)=W(K)-PARINC*W(IW)
      IF (IACT(K) .GT. MEQ) W(K)=DMAX1(ZERO,W(K))
  600 CONTINUE
  601 IF (KDROP .EQ. 0) GOTO 680
C
C     DELETE THE CONSTRAINT TO BE DROPPED.
C     SHIFT THE VECTOR OF SCALAR PRODUCTS.
C     THEN, IF APPROPRIATE, MAKE ONE MORE SCALAR PRODUCT ZERO.
C
      NU=NACT+1
      MFLAG=2
      GOTO 800
  610 IWS=IWS-NACT-1
      NU=MIN0(N,NU)
      DO 620 I=1,NU
      IS=IWS+I
      J=IS+NACT
  620 W(IS)=W(J+1)
      NFLAG=2
      GOTO 860
C
C     CALCULATE THE STEP TO THE VIOLATED CONSTRAINT.
C
  630 IS=IWS+NACT
  640 SUMY=W(IS+1)
      IF (SUMY.EQ.0.0D0) THEN
         INFO=3
         RETURN
      ENDIF
      STEP=-RES/SUMY
      PARINC=STEP/SUMY
      IF (NACT .EQ. 0) GOTO 660
C
C     CALCULATE THE CHANGES TO THE LAGRANGE MULTIPLIERS, AND REDUCE
C     THE STEP ALONG THE NEW SEARCH DIRECTION IF NECESSARY.
C
      LFLAG=2
      GOTO 740
  650 IF (KDROP .EQ. 0) GOTO 660
      TEMP=ONE-RATIO/PARINC
      IF (TEMP .LE. ZERO) KDROP=0
      IF (KDROP .EQ. 0) GOTO 660
      STEP=RATIO*SUMY
      PARINC=RATIO
      RES=TEMP*RES
C
C     UPDATE X AND THE LAGRANGE MULTIPIERS.
C     DROP A CONSTRAINT IF THE FULL STEP IS NOT TAKEN.
C
  660 IWY=IWZ+NACT*N
      DO 670 I=1,N
      IY=IWY+I
  670 X(I)=X(I)+STEP*W(IY)
      PARNEW=PARNEW+PARINC
      IF (NACT .GE. 1) GOTO 590
C
C     ADD THE NEW CONSTRAINT TO THE ACTIVE SET.
C
  680 NACT=NACT+1
      W(NACT)=PARNEW
      IACT(NACT)=KNEXT
      IA=IWA+KNEXT
      IF (KNEXT .GT. MN) IA=IA-N
      W(IA)=-W(IA)
C
C     ESTIMATE THE MAGNITUDE OF X. THEN BEGIN A NEW ITERATION,
C     RE-INITILISING X IF THIS MAGNITUDE IS SMALL.
C
      JFLAG=2
      GOTO 910
  690 IF (SUM .LT. (XMAGR*XMAG)) GOTO 230
C      IF (ITREF) 450,450,250
      IF (ITREF .LE. 0) THEN
         GOTO 450
      ELSE
         GOTO 250
      ENDIF
C
C     INITIATE ITERATIVE REFINEMENT IF IT HAS NOT YET BEEN USED,
C     OR RETURN AFTER RESTORING THE DIAGONAL ELEMENTS OF G.
C
  700 IF (ITERC .EQ. 0) GOTO 710
      ITREF=ITREF+1

      JFINC=-1
      IF (ITREF .EQ. 1) GOTO 250

C TERMINATION ACCURACY CANNOT BE REACHED DUE TO NUMERICAL INSTABILITIES
  710 IF (INFO .LT. 0 .AND. MINCV .LT. 1D-8) THEN
        INFO = 4
        B(1)=MINCV + VSMALL
      ENDIF
      IF (.NOT. LQL) RETURN
      DO 720 I=1,N
      ID=IWD+I
  720 G(I,I)=W(ID)
  730 RETURN
C
C
C     THE REMAINING INSTRUCTIONS ARE USED AS SUBROUTINES.
C
C
C********************************************************************
C
C
C     CALCULATE THE LAGRANGE MULTIPLIERS BY PRE-MULTIPLYING THE
C     VECTOR IN THE S-PARTITION OF W BY THE INVERSE OF R.
C
  740 IR=IWR+(NACT+NACT*NACT)/2
      I=NACT
      SUM=ZERO
      GOTO 770
  750 IRA=IR-1
      SUM=ZERO
      IF (NACT.EQ.0) GOTO 761
      DO 760 J=I,NACT
      IW=IWW+J
      SUM=SUM+W(IRA)*W(IW)
  760 IRA=IRA+J
  761 IR=IR-I
      I=I-1
  770 IW=IWW+I
      IS=IWS+I
      W(IW)=(W(IS)-SUM)/W(IR)
      IF (I .GT. 1) GOTO 750
      IF (LFLAG .EQ. 3) GOTO 390
      IF (LFLAG .EQ. 4) GOTO 571
C
C     CALCULATE THE NEXT CONSTRAINT TO DROP.
C
C  775 IP=IWW+1
C      IPP=IWW+NACT
  775 KDROP=0
      IF (NACT.EQ.0) GOTO 791
      DO 790 K=1,NACT
      IF (IACT(K) .LE. MEQ) GOTO 790
      IW=IWW+K
      IF ((RES*W(IW)) .GE. ZERO) GOTO 790
      IF (W(IW).EQ.0.0D0) THEN
         INFO=3
         RETURN
      ENDIF
      TEMP=W(K)/W(IW)
      IF (KDROP .EQ. 0) GOTO 780
      IF (DABS(TEMP) .GE. DABS(RATIO)) GOTO 790
  780 KDROP=K
      RATIO=TEMP
  790 CONTINUE
  791 GOTO (580,650), LFLAG
C
C
C********************************************************************
C
C
C     DROP THE CONSTRAINT IN POSITION KDROP IN THE ACTIVE SET.
C
  800 IA=IWA+IACT(KDROP)
      IF (IACT(KDROP) .GT. MN) IA=IA-N
      W(IA)=-W(IA)
      IF (KDROP .EQ. NACT) GOTO 850
C
C     SET SOME INDICES AND CALCULATE THE ELEMENTS OF THE NEXT
C     GIVENS ROTATION.
C
      IZ=IWZ+KDROP*N
      IR=IWR+(KDROP+KDROP*KDROP)/2
  810 IRA=IR
      IR=IR+KDROP+1
      TEMP=DMAX1(DABS(W(IR-1)),DABS(W(IR)))
      IF (TEMP.GT.VSMALL) THEN
         SUM=TEMP*DSQRT((W(IR-1)/TEMP)**2+(W(IR)/TEMP)**2)
      ELSE
         SUM=VSMALL
      ENDIF
      GA=W(IR-1)/SUM
      GB=W(IR)/SUM
C
C     EXCHANGE THE COLUMNS OF R.
C
      DO 820 I=1,KDROP
      IRA=IRA+1
      J=IRA-KDROP
      TEMP=W(IRA)
      W(IRA)=W(J)
  820 W(J)=TEMP
      W(IR)=ZERO
C
C     APPLY THE ROTATION TO THE ROWS OF R.
C
      W(J)=SUM
      KDROP=KDROP+1
      DO 830 I=KDROP,NU
      TEMP=GA*W(IRA)+GB*W(IRA+1)
      W(IRA+1)=GA*W(IRA+1)-GB*W(IRA)
      W(IRA)=TEMP
  830 IRA=IRA+I
C
C     APPLY THE ROTATION TO THE COLUMNS OF Z.
C
      DO 840 I=1,N
      IZ=IZ+1
      J=IZ-N
      TEMP=GA*W(J)+GB*W(IZ)
      W(IZ)=GA*W(IZ)-GB*W(J)
  840 W(J)=TEMP
C
C     REVISE IACT AND THE LAGRANGE MULTIPLIERS.
C
      IACT(KDROP-1)=IACT(KDROP)
      W(KDROP-1)=W(KDROP)
      IF (KDROP .LT. NACT) GOTO 810
  850 NACT=NACT-1
      GOTO (250,610), MFLAG
C
C
C********************************************************************
C
C
C     APPLY GIVENS ROTATION TO REDUCE SOME OF THE SCALAR
C     PRODUCTS IN THE S-PARTITION OF W TO ZERO.
C
  860 IZ=IWZ+NU*N
  870 IZ=IZ-N
  880 IS=IWS+NU
      NU=NU-1
      IF (NU .EQ. NACT) GOTO 900
      IF (W(IS) .EQ. ZERO) GOTO 870
      TEMP=DMAX1(DABS(W(IS-1)),DABS(W(IS)))
      SUM=TEMP*DSQRT((W(IS-1)/TEMP)**2+(W(IS)/TEMP)**2)
      GA=W(IS-1)/SUM
      GB=W(IS)/SUM
      W(IS-1)=SUM
      DO 890 I=1,N
      K=IZ+N
      TEMP=GA*W(IZ)+GB*W(K)
      W(K)=GA*W(K)-GB*W(IZ)
      W(IZ)=TEMP
  890 IZ=IZ-1
      GOTO 880
  900 GOTO (560,630), NFLAG
C
C
C********************************************************************
C
C
C     CALCULATE THE MAGNITUDE OF X AN REVISE XMAG.
C
  910 SUM=ZERO
      DO 920 I=1,N
      SUM=SUM+DABS(X(I))*VFACT*(DABS(GRAD(I))+DABS(G(I,I)*X(I)))
      IF (LQL) GOTO 920
      IF (SUM .LT. 1.D-30) GOTO 920
      VFACT=1.D-5*VFACT
      SUM=1.D-5*SUM
      XMAG=1.D-5*XMAG
  920 CONTINUE
      XMAG=DMAX1(XMAG,SUM)
      GOTO (420,690), JFLAG
C
C
C********************************************************************
C
C
C     PRE-MULTIPLY THE VECTOR IN THE W-PARTITION OF W BY Z TRANSPOSE.
C
  930 JL=IWW+1
      IZ=IWZ
      DO 940 I=1,N
      IS=IWS+I
      W(IS)=ZERO
      IWWN=IWW+N
      DO 940 J=JL,IWWN
      IZ=IZ+1
  940 W(IS)=W(IS)+W(IZ)*W(J)
      GOTO (350,550), KFLAG
      RETURN
      END


Module general_structural_functions
	use math_constants
	use quadratures
	use hssw_structure
	use hd_structure
	Implicit None
	contains

	!Function that calculates the radial distribution function g(r) through the
	!structure factor. The function needs:
	! "r" -> value of the radial length
	! "rho" -> particle density of the system
	! "k" -> wave vector array
	! "kw" -> wave vector weights
	! "sk" -> structure factor
	Function radial_dist_3D(r,rho,k,kw,s) result(g)
		Implicit None
		Real * 8, intent(in) :: r, rho !radial length and density
		Real * 8, intent(in), dimension(:) :: k, kw, s !wave vector, weights and structure factor
		Real * 8 :: g
		Real * 8, dimension(size(k)) :: integrand
		Integer :: i1
		do i1 = 1, size(k)
			if ( k(i1) * r >= 0.075d0 ) integrand(i1) = dsin( k(i1) * r ) / r
			if ( k(i1) * r <  0.075d0 ) integrand(i1) = k(i1) - (( r * r * (k(i1) ** 3))/6.d0)
			!integrand(i1) = sin( k(i1) * r ) / r
			integrand(i1) = k(i1) * kw(i1) * (S(i1) - 1.d0) * integrand(i1)
		end do
		g = 1.d0 + ( 1.d0 / ( 2.d0 * rho *  pi * pi ) ) * sum(integrand)
		return
	End function

	!Function that calculates the radial distribution function g(r) through the
	!structure factor. The function needs:
	! "r" -> value of the radial length
	! "rho" -> particle density of the system
	! "k" -> wave vector array
	! "kw" -> wave vector weights
	! "sk" -> structure factor
	Function radial_dist_2D(r,rho,k,kw,s) result(g)
		Implicit None
		Real * 8, intent(in) :: r, rho !radial length and density
		Real * 8, intent(in), dimension(:) :: k, kw, s !wave vector, weights and structure factor
		Real * 8 :: g
		Real * 8, dimension(size(k)) :: integrand
		Integer :: i1
		do i1 = 1, size(k)
			if ( k(i1) * r >= 0.075d0 ) integrand(i1) = dsin( k(i1) * r ) / r
			if ( k(i1) * r <  0.075d0 ) integrand(i1) = k(i1) - (( r * r * (k(i1) ** 3))/6.d0)
			!integrand(i1) = sin( k(i1) * r ) / r
			integrand(i1) = k(i1) * kw(i1) * (S(i1) - 1.d0) * integrand(i1)
		end do
		g = 1.d0 + ( 1.d0 / ( 2.d0 * rho *  pi * pi ) ) * sum(integrand)
		return
	End function

	!Function that calculates the coordination number integral for a given set of points
	!given the value up to the starting point. The function needs:
	! "rho" -> system density
	! "coor_last" -> the value of the coordination number up to the starting value of the integral
	! "r" -> radial distance vector
	! "rw" -> weights of the radial distance
	! "gr" -> radial distribution function evaluated in the "r" distances
	Function coordination_num_3D(rho,coor_last,r,rw,gr) result (coor_n)
		Implicit None
		Real * 8, intent(in) :: rho,coor_last
		Real * 8, intent(in), dimension(:) :: r, rw, gr
		Real * 8 :: coor_n
		Real * 8, dimension(size(r)) :: integrand
		integrand = r * r  * gr * rw
		coor_n = coor_last + 4.d0 * pi * rho * sum(integrand)
		return
	End Function

	!Function that calculates the potential energy of the system
	! "rho" -> system density
	! "r" -> radial distance vector
	! "rw" -> weights of the radial distance
	! "gr" -> radial distribution function evaluated in the "r" distances
	! "ur" -> pair potential array for each distance
	! "energy" -> output value of the energy
	Function pot_energy_3D(rho,r,rw,gr,ur) result (energy)
		Implicit None
		Real * 8, intent(in) :: rho
		Real * 8, intent(in), dimension(:) :: r, rw, gr, ur
		Real * 8 :: energy
		Real * 8, dimension(size(r)) :: integrand
		integrand = r * r  * gr * ur * rw
		energy = 2.d0 * pi * rho * sum(integrand)
		return
	End Function

	!This subroutine calculates the radial distribution function as well as some other
	!properties dependent of this function. This function needs:
	! "rho" -> system density
	! "k" -> Wave-vectors array to calculate the Fourier transform
	! "kw" -> Wave-vectors weights
	! "Sk" -> Structure Factor array
	! "r" -> radial distance array in which we want to compute "g(r)"
	! "dr" -> differential array of radial distance for each distance in the array "r"
	! "dr_quadp" -> quadrature points associated with the integrals over "g(r)"
	! "dr_quadw" -> quadrature weights associated with the integrals over "g(r)"
	!The outputs are:
	! "g_r" -> Radial distribution function "g(r)"
	! "coor_n_r" -> Coordination number depending on the cutting value "r"
	! "d" -> dimension of the system
	Subroutine calc_gr_dependent_functions(rho,k,kw,Sk,r,dr_quadp,dr_quadw,g_r,coor_n_r,d)
		Implicit None
		Real * 8, intent(in), dimension(:) :: k, kw, Sk, r, dr_quadp, dr_quadw
		Real * 8, intent(out), dimension(:) :: g_r,coor_n_r
		Real * 8, intent(in) :: rho
		Integer, intent(in) :: d
		Real * 8, dimension(size(dr_quadp)) :: drqp, drqw, dg_r
		Real * 8 :: dr,coor_n_last
		Integer :: i1,i2
		!open(unit=11, file="gr_test_F.dat", status="replace")
	  coor_n_r = 0.d0
		coor_n_last = 0.d0
		drqw = dr_quadw
		dr = r(2)-r(1)
		if (d == 3) then
			Do i1=1, size(r)
				drqp = dr_quadp + r(i1) - dr
				g_r(i1)=  radial_dist_3D(r(i1),rho,k,kw,sk)
			   do i2=1, size(drqp)
			     dg_r(i2) = radial_dist_3D(drqp(i2),rho,k,kw,sk)
			   end do
			   coor_n_r(i1) = coordination_num_3D(rho,coor_n_last,drqp,drqw,dg_r)
			  ! write(11,*) r, gr,grtail, gr+grtail,ncoor, (ncoor)/(4.d0 * pi *rho* (r ** 3)/3.d0)
			   coor_n_last = coor_n_r(i1)
		  End do
		Else if(d == 2) Then
		End If
	  !close(11)
	End Subroutine

	!This subroutine writes down the information of the system used, as well as the
	!approximation scheme
	Subroutine sys_writting(sys,sysp,approx,i_unit)
		Implicit None
		Real * 8, dimension(:), intent(in) :: sysp
		Character(len=4), intent(in) :: sys,approx
		Integer :: i_unit
		select case(sys)
		case("HSSW")
			call writting_hssw_p(sysp,approx,i_unit)
		case("HD00")
			call writting_hd_p(sysp,approx,i_unit)
		case("HS00")
			call writting_hs_p(sysp,approx,i_unit)
		end select
	End Subroutine

	!This subroutine is for the writting of the structure factor as well as the
	!weights of the quadrature and the information file
	Subroutine s_writting(k,sk,kw,i_unit)
		Implicit None
		Real * 8, dimension(:), intent(in) :: k, sk, kw
		Integer :: i1
		Integer, intent(in) :: i_unit
		!k S(k) kw WRITTING
		Write (i_unit,*) "# 			k 								S(k)								Weights"
		Do i1=1, size(k)
			Write(i_unit,*) k(i1),sk(i1),kw(i1)
		End Do
	End Subroutine

	!This subroutine is for the writting of the radial distribution function
	!as well as other radial distance dependent functions
	Subroutine g_writting(r,gr,coor_n_r,i_unit)
		Implicit None
		Real * 8, dimension(:), intent(in) :: r, gr,coor_n_r
		Integer, Intent (in) :: i_unit
		Integer :: i1
		Write (i_unit,*) "# 			r 								g(r)						Coordination Number"
		Do i1=1, size(r)
			Write(i_unit,*) r(i1),gr(i1),coor_n_r(i1)
		End Do
	End Subroutine

	!This subroutine is for the information with respect the wave-vectors used
	Subroutine k_info_writting(k,quadp,k_quad,i_unit)
		Implicit None
		Real * 8, dimension(:), intent(in) :: k,quadp
		Character(*), intent(in) :: k_quad
		Integer :: i1
		Integer, intent(in) :: i_unit
		!INFO FILE WRITTING
		Write(i_unit,*) "### Wave-Vectors Quadrature ###"
		Call quad_writting(k_quad,i_unit,quadp)
		Write(i_unit,*) "### Wave-Vectors General INFO ###"
		Write(i_unit,*) "number of points     = ", size(k)
		Write(i_unit,*) "k minimum value      = ", k(1)
		Write(i_unit,*) "k maximum value      = ", k(size(k))
	End Subroutine

	!This subroutine is for the information with respect the radial distance used
	Subroutine r_info_writting(r,r_params,r_quad,i_unit)
		Implicit None
		Real * 8, dimension(:), intent(in) :: r, r_params
		Character(*), intent(in) :: r_quad
		Integer, intent(in) :: i_unit
		!INFO FILE WRITTING
		Write(i_unit,*) "### Radial distance Quadrature ###"
		Call quad_writting(r_quad,i_unit,r_params)
		Write(i_unit,*) "### Radial distance General INFO ###"
		Write(i_unit,*) "number of points     = ", size(r)
		Write(i_unit,*) "r minimum value      = ", r(1)
		Write(i_unit,*) "r maximum value      = ", r(size(r))
	End Subroutine

	!This subroutine is for the information with respect the potential
	Subroutine Energy_info_writting(energy,r_params,r_quad,i_unit)
		Implicit None
		Real * 8 :: energy
		Real * 8, dimension(:), intent(in) :: r_params
		Character(*), intent(in) :: r_quad
		Integer, intent(in) :: i_unit
		!INFO FILE WRITTING
		Write(i_unit,*) "### Potential Energy info ###"
		Write(i_unit,*) "Potential Energy     = ", energy
		Call quad_writting(r_quad,i_unit,r_params)
	End Subroutine

	!This subroutine is for the information with respect the radial distance differential used
	Subroutine dr_info_writting(dr,dr_w,dr_params,dr_quad,i_unit)
		Implicit None
		Real * 8, dimension(:), intent(in) :: dr, dr_w, dr_params
		Character(*), intent(in) :: dr_quad
		Integer, intent(in) :: i_unit
		Integer :: i1
		Write(i_unit,*) "### Radial distance Differencial General INFO ###"
		Write(i_unit,*) "number of points     = ", size(dr)
		Write(i_unit,*) "dr minimum value      = ", dr(1)
		Write(i_unit,*) "dr maximum value      = ", dr(size(dr))
		Write(i_unit,*) "###############################"
		Write(i_unit,*) "### Radial distance Differencial Quadrature ###"
		Call quad_writting(dr_quad,i_unit,dr_params)
		Write(i_unit,*) "### Radial distance Differencial Quadrature values ###"
		Write(i_unit,*) "						r												Weights"
		Do i1=1, size(dr)
			Write(i_unit,*) dr(i1), dr_w(i1)
		End Do
		Write(i_unit,*) "###############################"
	End Subroutine

	Subroutine file_name_constructor(sys,sysp,folder,preffix,id,suffix,file_name)
		Implicit None
		Real * 8, dimension(:), intent(in) :: sysp
		Character(*), intent(in) :: sys,folder,preffix,suffix
		Integer, intent(in) :: id
		Real * 8 :: phi, T, lambda, z
		Integer :: i_phi, di_phi, i_T, di_T, i_L, di_L, i_z, di_z
		Integer, parameter :: i_phi_m=1, di_phi_m=6, i_T_m =2, di_T_m = 6, id_m=2
		Integer, parameter :: i_L_m = 2, di_L_m = 2, i_z_m = 2, di_z_m = 2
		Character (len=i_phi_m+di_phi_m+1) :: phi_char
		Character (len=i_T_m+di_T_m+1) :: T_char
		Character (len=i_L_m+di_L_m+1) :: L_char
		Character (len=i_z_m+di_z_m+1) :: z_char
		Character (len=id_m) :: id_char
		Character (len=100) :: sys_ID
		Character (*) :: file_name
		Character (len=50) :: FMT0,FMT1,FMT2,FMTID
		Integer :: i1
		!Global Formats
		Write(FMT0,"(A,I1,A1,I1,A5,I1,A1,I1,A1)") "(I",i_phi_m,".",i_phi_m,",A1,I",di_phi_m,".",di_phi_m,")"
		Write(FMTID,"(A2,I1,A1,I1,A1)") "(I",id_m,".",id_m,")"
		!Global character variables
		phi = sysp(1)
		i_phi = int(phi)
		di_phi = nint((phi - dble(i_phi)) * (10.d0 ** di_phi_m) )
		Write(id_char,trim(FMTID)) id
		Write(phi_char,trim(FMT0)) i_phi,"_",di_phi
		!System selector
		select case(sys)
		case("HSSW")
			!Formats
			Write(FMT1,"(A2,I1,A1,I1,A5,I1,A1,I1,A1)") "(I",i_T_m,".",i_T_m,",A1,I",di_T_m,".",di_T_m,")"
			Write(FMT2,"(A2,I1,A1,I1,A5,I1,A1,I1,A1)") "(I",i_L_m,".",i_L_m,",A1,I",di_L_m,".",di_L_m,")"
			!System conditions
			lambda = sysp(3)
			T = sysp(2)
			!Calculating the associated integers for phi, T and lambda:
			i_T = int(T)
			di_T = nint( (T- dble(i_T)) * (10.d0 ** di_T_m) )
			i_L = int(lambda)
			di_L = nint( (lambda- dble(i_L)) * (10.d0 ** di_L_m) )
			!Writting character variables
			Write(T_char,FMT1) i_T,"_",di_T
			Write(L_char,FMT2) i_L,"_",di_L
			Write(id_char,"(I2.2)") id
			!Writting System ID
			sys_ID = trim("_HSSW_phi_"//phi_char//"_T_"//T_char//"_L_"//L_char//"_id_"//id_char)
		case("HD00")
			!Writting System ID
			sys_ID = trim("_HD_phi_"//phi_char//"_id_"//id_char)
		case("HS00")
			!Writting System ID
			sys_ID = trim("_HS_phi_"//phi_char//"_id_"//id_char)
		case("HSAY")
			!Formats
			Write(FMT1,"(A2,I1,A1,I1,A5,I1,A1,I1,A1)") "(I",i_T_m,".",i_T_m,",A1,I",di_T_m,".",di_T_m,")"
			Write(FMT2,"(A2,I1,A1,I1,A5,I1,A1,I1,A1)") "(I",i_z_m,".",i_z_m,",A1,I",di_z_m,".",di_z_m,")"
			!System conditions
			z = sysp(3)
			T = sysp(2)
			!Calculating the associated integers for phi, T and lambda:
			i_T = int(T)
			di_T = nint( (T- dble(i_T)) * (10.d0 ** di_T_m) )
			i_z = int(z)
			di_z = nint( (z- dble(i_z)) * (10.d0 ** di_z_m) )
			!Writting character variables
			Write(T_char,FMT1) i_T,"_",di_T
			Write(z_char,FMT2) i_z,"_",di_z
			Write(id_char,"(I2.2)") id

			!Writting System ID
			sys_ID = trim("_HSAY_phi_"//phi_char//"_T_"//T_char//"_z_"//z_char//"_id_"//id_char)
		case default
			sys_ID = trim(sys//"_phi_"//phi_char//"_id_"//id_char)
		end select
		file_name = trim(trim(folder)//trim(preffix)//trim(sys_ID)//trim(suffix))
	End Subroutine
End Module


module fib_mod
    use, intrinsic :: iso_fortran_env, only : I8 => INT64, DP => REAL64
    implicit none

    private
    public :: fib_recursive, fib_skip_ahead, fib_memoization, &
        fib_iterative, fib_closed_form

contains

    recursive function fib_recursive(n) result(fib)
        implicit none
        integer(Kind=I8), value :: n
        integer(kind=I8) :: fib

        if (n == 0_I8) then
            fib = 0_I8
        else if (n == 1_I8) then
            fib = 1_I8
        else
            fib = fib_recursive(n - 1_I8) + fib_recursive(n - 2_I8)
        end if
    end function fib_recursive

    recursive function fib_skip_ahead(n) result(fib)
        implicit none
        integer(kind=I8), value :: n
        integer(kind=I8) :: fib
        if (n == 0_I8) then
            fib = 0_I8
        else if (n == 1_I8 .or. n == 2_I8) then
            fib = 1_I8
        else if (mod(n, 2_I8) == 0) then
            fib = fib_skip_ahead(n/2_I8)*(fib_skip_ahead(n/2_I8 + 1_I8) + &
                                          fib_skip_ahead(n/2_I8 - 1_I8))
        else
            fib = fib_skip_ahead(n/2_I8 + 1_I8)**2 + fib_skip_ahead(n/2_I8)**2
        end if
    end function fib_skip_ahead

    recursive function fib_memoization(n) result(fib)
        implicit none
        integer(kind=I8), value :: n
        integer(kind=I8) :: fib
        integer(kind=I8), parameter :: buffer_size = 1000000
        integer(kind=I8), dimension(0:buffer_size), save :: buffer = -1_I8

        buffer(0) = 0_I8
        buffer(1) = 1_I8
        if (n <= buffer_size) then
            if (buffer(n) == -1_I8) then
                buffer(n) = fib_memoization(n - 1_I8) + fib_memoization(n - 2_I8)
            end if
            fib = buffer(n)
        else
            fib = fib_memoization(n - 1_I8) + fib_memoization(n - 2_I8)
        end if
    end function fib_memoization

    function fib_iterative(n) result(fib)
        implicit none
        integer(kind=I8), value :: n
        integer(kind=I8) :: fib
        integer(kind=I8) :: fib_n_1, i, tmp

        if (n == 0_I8) then
            fib = 0_I8
        else
            fib_n_1 = 0_I8
            fib = 1_I8
            do i = 2_I8, n
                tmp = fib
                fib = fib + fib_n_1
                fib_n_1 = tmp
            end do
        end if
    end function fib_iterative

    function fib_closed_form(n) result(fib)
        implicit none
        integer(kind=I8), value :: n
        integer(kind=I8) :: fib
        real(kind=DP) :: alpha = (1.0_DP + sqrt(5.0_DP))/2.0_DP, &
                         beta  = (1.0_DP - sqrt(5.0_DP))/2.0_DP, &
                         pre_factor = 1.0_DP/sqrt(5.0_DP)

        fib = nint(pre_factor*(alpha**n - beta**n), kind=I8)
    end function fib_closed_form

end module fib_mod


! Created by EverLookNeverSee@GitHub on 6/10/20
! For more information see FCS/img/Exercise_11.png

program main
    implicit none
    ! declaring variables
    integer :: i, j, k , root
    logical(1), dimension(1000) :: a
    ! initializing variables
    ! setting .true. for all elements of array
    a = .true.
    ! assigning false to first element of array(1 is not prime)
    a(1) = .false.
    ! calculating square root of size of array
    ! because we don't need to check all elements of array
    ! if i^2 > size of array, there is no non-prime number in array.
    root = int(sqrt(real(size(a))))
    ! checking elements of array
    do i = 2, root
        if (a(i)) then  ! if a(i) is true
            ! set all multiples of i as false
            do j = i * i, size(a), i
                a(j) = .false.
            end do
        end if
    end do
    ! print all true(prime) numbers that are remained in array
    do k = 1, size(a)
        if (a(k)) then
            print *, k
        end if
    end do
end program main


!==============================================================================
!
!> @anchor  test_mean2true
!!
!> @brief   Program for testing transformation mean anomaly to true anomaly and vice versa.
!!		S/R from slam_astro_conversions are used
!!
!> @author  Eduard Gamper (EG)
!!
!> @date

!!
05.01.2015 (initial design)

!!

!!
!! @details Program for testing transformation mean anomaly to true anomaly and vice versa.
!!		Used equations in functions: Vallado, S.54 eq.2-6, S.56 eq. 2-13, 2-14
!!
!!
!------------------------------------------------------------------------

Program test_mean2true

use slam_astro_conversions
use slam_io, only: slam_message
use slam_types
use slam_time
use slam_orbit_types
use slam_math, only: eps15, eps9, eps6, eps3

implicit none

type(kepler_t) :: state_kepler			! State vector with Kepler elements
type(kepler_t) :: state_kepler_literature	! State vector with Kepler elements
						!              (1) = semimajor axis [km]
						!              (2) = eccentricity
						!              (3) = orbit inclination [rad]
						!              (4) = r.a. of asc. node [rad]
						!              (5) = argument of perigee [rad]
						!              (6) = mean anomaly [rad]

logical 	:: error = .false.		! Error flag
logical 	:: error_all = .false.		! Error flag

! QUELLE: http://www.tle.info/data/ISS_DATA.TXT
!
!               M50 Cartesian                         M50 Keplerian
!     -----------------------------------       --------------------------------
!      X    =        3831218.94                 A    =         6778927.15  meter
!      Y    =       -3769807.71  meter          E    =           .0013488
!      Z    =        4131046.64                 I    =           51.67403
!      XDOT =       6287.659929                 Wp   =           38.31673
!      YDOT =       2227.041971  meter/sec      RA   =          172.87570  deg
!      ZDOT =      -3782.037544                 TA   =           90.71589
!                                               MA   =           90.56134
!                                               Ha   =            220.633  n.mi
!                                               Hp   =            212.869

! subroutine mean2true(         &
!                       Ecc,    &  ! <-- DBL  eccentricity
!                       M,      &  ! <-- DBL  mean anomaly / rad
!                       E0,     &  ! --> DBL  eccentric anomaly / rad
!                       Nu      &  ! --> DBL  true anomaly / rad
!                     )

! subroutine true2mean(       &
!                       Ecc,  & ! <-- DBL eccentricity
!                       Nu,   & ! <-- DBL true anomly in rad
!                       E0,   & ! --> DBL eccentric anomaly in rad
!                       M     & ! --> DBL mean anomaly in rad
!                     )

state_kepler_literature%ecc  = 0.0013488d0
state_kepler_literature%man  = 90.56134d0/180*pi
state_kepler_literature%tran = 90.71589d0/180*pi

state_kepler%ecc = state_kepler_literature%ecc
state_kepler%man = state_kepler_literature%man

write(*,*) ''
write(*,*) 'Testing transformation mean anomaly to true anomaly and vice versa'
write(*,*) 'Functions mean2true() and true2mean() from module slam_astro_legacy are used'
write(*,*) ''
write(*,*) '------- Example ISS -------'
write(*,*) '--Data from literature (ISS-Orbit):'
write(*,*) 'Eccentricity: ', state_kepler_literature%ecc
write(*,*) 'Mean anomaly: ', state_kepler_literature%man*180/pi
write(*,*) 'True anomaly: ', state_kepler_literature%tran*180/pi

!Transform mean anomaly to true anomaly
CALL mean2true(state_kepler%ecc, state_kepler%man, state_kepler%ecan, state_kepler%tran)

write(*,*) '--Transform mean anomaly to true anomaly (ISS-Orbit):'
write(*,*) 'True anomaly: ', state_kepler%tran*180/pi
write(*,*) 'Eccentric anomaly: ', state_kepler%ecan*180/pi

!** Compare results of s/r mean2true(); use of eps6 because iteration from mean 2 true has allowed deviation of eps9
if (abs(state_kepler%tran - state_kepler_literature%tran) .gt. eps6) error = .true.

!** Display conclusion
if (error) then
  CALL slam_message('mean2true not passed.',1)
  error_all = .true.
else
  CALL slam_message('mean2true passed.', 1)
end if

!Transform true anomaly back to mean anomaly
CALL true2mean(state_kepler%ecc, state_kepler%tran, state_kepler%ecan, state_kepler%man)

write(*,*) '--Transform true anomaly back to mean anomaly (ISS-Orbit):'
write(*,*) 'Mean anomaly: ', state_kepler%man*180/pi
write(*,*) 'Eccentric anomaly: ', state_kepler%ecan*180/pi

!** Set error flag back to false
error = .false.

!** Compare results of s/r true2mean()
if (abs(state_kepler%man - state_kepler_literature%man) .gt. eps6) error = .true.

!** Display conclusion
if (error) then
  CALL slam_message('true2mean not passed.',1)
  error_all = .true.
else
  CALL slam_message('true2mean passed.', 1)
end if

! Example: High eccentricity
! 0 MOLNIYA 3-50
! 1 25847U 99036A   15310.12862371 -.00000116 +00000-0 -13949-3 0  9992
! 2 25847 062.6934 338.4194 7400458 260.6635 016.9238 02.00678845119668

! Mean Anomaly: 016.9238 deg
! Eccentricity: 0.7400458

state_kepler_literature%ecc   = 0.7400458d0
state_kepler_literature%man   = 16.9238d0/180*pi
state_kepler_literature%tran  = 99.203171087928723d0/180*pi !This is a calculated value (by s/r mean2true)

state_kepler%ecc = state_kepler_literature%ecc
state_kepler%man = state_kepler_literature%man
! state_kepler%tran=90.71589d0/180*pi

write(*,*) ''
write(*,*) '------- Example Molniya -------'
write(*,*) '--Data from literature (Molniya-Orbit):'
write(*,*) 'Eccentricity: ', state_kepler%ecc
write(*,*) 'Mean anomaly: ', state_kepler%man*180/pi
! write(*,*) 'True anomaly: ', state_kepler%tran*180/pi

!Transform mean anomaly to true anomaly (Molniya-Orbit)
CALL mean2true(state_kepler%ecc, state_kepler%man, state_kepler%ecan, state_kepler%tran)

write(*,*) '--Transform mean anomaly to true anomaly (Molniya-Orbit):'
write(*,*) 'True anomaly: ', state_kepler%tran*180/pi
write(*,*) 'Eccentric anomaly: ', state_kepler%ecan*180/pi

!** Set error flag back to false
error = .false.

!** Compare results of s/r mean2true()
if (abs(state_kepler%tran - state_kepler_literature%tran) .gt. eps6) error = .true.
write(*,*) abs(state_kepler%tran - state_kepler_literature%tran)

!** Display conclusion
if (error) then
  CALL slam_message('mean2true not passed.',1)
  error_all = .true.
else
  CALL slam_message('mean2true passed.', 1)
end if

!Transform true anomaly back to mean anomaly (Molniya-Orbit)
CALL true2mean(state_kepler%ecc, state_kepler%tran, state_kepler%ecan, state_kepler%man)

write(*,*) '--Transform true anomaly back to mean anomaly (Molniya-Orbit):'
write(*,*) 'Mean anomaly: ', state_kepler%man*180/pi
write(*,*) 'Eccentric anomaly: ', state_kepler%ecan*180/pi

!** Set error flag back to false
error = .false.

!** Compare results of s/r true2mean()
if (abs(state_kepler%man - state_kepler_literature%man) .gt. eps6) error = .true.

!** Display conclusion
if (error) then
  CALL slam_message('true2mean not passed.',1)
  error_all = .true.
else
  CALL slam_message('true2mean passed.', 1)
end if

!** Display conclusion for complete test
if (error_all) then
  CALL slam_message('Failed.',1)
  error_all = .true.
else
  CALL slam_message('All tests passed.', 1)
end if

end Program test_mean2true


module p_mpfun_e1 ! Модуль рассчета E_1 на многократной точности
use mpmodule      ! Пожключение модуля многократной точности
implicit none

contains

type (mp_real) function e141_mp(x)
use mpmodule                          ! Функция e141(x) вычисляет для
implicit none                         ! аргумента (x) значение первой
type (mp_real) x,w,g                  ! интегрально-показательной
                                      ! функции E1(x).

call mpinit (500) ! Инициализатор параметров MPFUN (таких как точность)
                  ! Подробнее смотри в руководстве или в файле mpmod90.f

! Многократная точность позволяет уточнить постоянную Эйлера. Для сравнения с результатами
! четверной точности можно положить g таким, каким оно было задано в файле p_e1.f
 g = MPREAL('0.5772156649015328606065120900824024310421593359399235988')
!g = MPREAL('0.57721566490153286061')

! Процедура MPREAL преобразует число типа REAL в переменную типа MP_REAL
! Процедуры EXP и LOG расширены для работы с переменными типа MP_REAL
! Подробнее смотри в руководстве или в файле mpmod90.f

if (x .ge. MPREAL('5.0')) then           ! Расчёт ведется на основе известных
        w=e141c_mp(x)/x*EXP(-x)          ! разложений E1(x) в ряд по полиномам
else                                     ! Чебышева (см. книгу Люка:
        if (x .gt. MPREAL('0.0')) then   ! Специальные математические
                w=e141a_mp(x)-g-LOG(x)   ! функции и их аппроксимации.
        else                             ! Издательство "МИР". Москва, 1980.
        w = MPREAL('1.0')                ! стр. 112-113 (таблица 4.1).
        endif
endif
e141_mp=w
end function e141_mp

type (mp_real) function e141a_mp(x)     ! Функция e141a(x) вычисляет для заданного аргумента
use mpmodule                            ! ( 0 <= x <= 8 ) значение E1(x)+gamma+ln(x) через
implicit none                           ! разложение в ряд по смещенным полиномам Чебышева.
type (mp_real) x                        ! Коэффициенты разложения взяты из книги  Ю.Люка
type (mp_real) a(0:24)                  ! Специальные математические функции и их
type (mp_real) w,z                      ! аппроксимации. Издательство "МИР". Москва, 1980.
type (mp_real) b0, b1, b2               !                          стр. 112 (таблица 4.1).
integer  i

call mpinit (500)

a(0)  = MPREAL(' 1.67391435474272057853')
a(1)  = MPREAL(' 1.22849447854715595018')
a(2)  = MPREAL('-0.31786989829837361369')          ! Здесь:
a(3)  = MPREAL(' 0.09274603919729219112')          !     E1(x) - первая интегрально-
a(4)  = MPREAL('-0.02602736316900119930')          !             показательная
a(5)  = MPREAL(' 0.00674815309464228057')          !             функция;
a(6)  = MPREAL('-0.00159897068934225285')          ! gamma - постоянная Эйлера
a(7)  = MPREAL(' 0.00034594453880095403')
a(8)  = MPREAL('-0.00006853652682011094')
a(9)  = MPREAL(' 0.00001248593239173701')
a(10) = MPREAL('-0.00000210134463871704')
a(11) = MPREAL(' 0.00000032818447981081')
a(12) = MPREAL('-0.00000004776878645154')
a(13) = MPREAL(' 0.00000000650581688192')
a(14) = MPREAL('-0.00000000083210193692')
a(15) = MPREAL(' 0.00000000010028101125')
a(16) = MPREAL('-0.00000000001142229304')
a(17) = MPREAL(' 0.00000000000123307945')
a(18) = MPREAL('-0.00000000000012648523')
a(19) = MPREAL(' 0.00000000000001235706')
a(20) = MPREAL('-0.00000000000000115226')
a(21) = MPREAL(' 0.00000000000000010276')
a(22) = MPREAL('-0.00000000000000000878')
a(23) = MPREAL(' 0.00000000000000000072')
a(24) = MPREAL('-0.00000000000000000006')

w=MPREAL('0.125')*x
z=MPREAL('4.0')*w-MPREAL('2.0')
b0=MPREAL('0.0')
b1=MPREAL('0.0')

do i=24, 0, -1
        b2=b1
        b1=b0
        b0=z*b1-b2+a(i)
enddo

e141a_mp=b0-b1*z/MPREAL('2.0')

end function e141a_mp

type (mp_real) function e141c_mp(x)  ! Функция e141c(x) вычисляет для заданного аргумента
use mpmodule                         ! ( x >= 5 ) значение выражения E1(x)*exp(x)*x через
implicit none                        ! его разложение в ряд по смещённым полиномам Чебышева.
type (mp_real) x                     ! Коэффициенты разложения взяты из книги
type (mp_real) c(0:30)               ! Ю.Люка  Специальные математические функции и их
type (mp_real) w,z                   ! аппроксимации. Издательство "МИР". Москва, 1980.
type (mp_real) b0,b1,b2              !                          стр. 112-113 (таблица 4.1 (c)).
integer i

call mpinit (500)

c(0)  = MPREAL(' 0.92078514445389391645')
c(1)  = MPREAL('-0.07343411783162128775')
c(2)  = MPREAL(' 0.00520981196727232977')
c(3)  = MPREAL('-0.00050214071989599012')
c(4)  = MPREAL(' 0.00005920796937926337')
c(5)  = MPREAL('-0.00000808564513097880')
c(6)  = MPREAL(' 0.00000123720385647926')
c(7)  = MPREAL('-0.00000020750176860703')
c(8)  = MPREAL(' 0.00000003756005474022')
c(9)  = MPREAL('-0.00000000725410976004')
c(10) = MPREAL(' 0.00000000148181601182')
c(11) = MPREAL('-0.00000000031795682863')
c(12) = MPREAL(' 0.00000000007126935828')
c(13) = MPREAL('-0.00000000001661231319')
c(14) = MPREAL(' 0.00000000000401155069')
c(15) = MPREAL('-0.00000000000100038792')
c(16) = MPREAL(' 0.00000000000025693341')
c(17) = MPREAL('-0.00000000000006780374')
c(18) = MPREAL(' 0.00000000000001834785')
c(19) = MPREAL('-0.00000000000000508209')
c(20) = MPREAL(' 0.00000000000000143861')
c(21) = MPREAL('-0.00000000000000041560')
c(22) = MPREAL(' 0.00000000000000012238')
c(23) = MPREAL('-0.00000000000000003669')
c(24) = MPREAL(' 0.00000000000000001119')
c(25) = MPREAL('-0.00000000000000000347')
c(26) = MPREAL(' 0.00000000000000000109')
c(27) = MPREAL('-0.00000000000000000035')
c(28) = MPREAL(' 0.00000000000000000011')
c(29) = MPREAL('-0.00000000000000000004')
c(30) = MPREAL(' 0.00000000000000000001')

w=MPREAL('5.0')/x
z=MPREAL('4.0')*w-MPREAL('2.0')
b0=MPREAL('0.0')
b1=MPREAL('0.0')

do i=30, 0, -1
        b2=b1
        b1=b0
        b0=z*b1-b2+c(i)
enddo

e141c_mp=b0-b1*z/MPREAL('2.0')

end function e141c_mp

end module p_mpfun_e1


program Median_Test

  real            :: a(7) = (/ 4.1, 5.6, 7.2, 1.7, 9.3, 4.4, 3.2 /), &
                     b(6) = (/ 4.1, 7.2, 1.7, 9.3, 4.4, 3.2 /)

  print *, median(a)
  print *, median(b)

contains

  function median(a, found)
    real, dimension(:), intent(in) :: a
      ! the optional found argument can be used to check
      ! if the function returned a valid value; we need this
      ! just if we suspect our "vector" can be "empty"
    logical, optional, intent(out) :: found
    real :: median

    integer :: l
    real, dimension(size(a,1)) :: ac

    if ( size(a,1) < 1 ) then
       if ( present(found) ) found = .false.
    else
       ac = a
       ! this is not an intrinsic: peek a sort algo from
       ! Category:Sorting, fixing it to work with real if
       ! it uses integer instead.
       call sort(ac)

       l = size(a,1)
       if ( mod(l, 2) == 0 ) then
          median = (ac(l/2+1) + ac(l/2))/2.0
       else
          median = ac(l/2+1)
       end if

       if ( present(found) ) found = .true.
    end if

  end function median

end program Median_Test