program matrice_grad

! compilation et lien: gfortran.exe -O matrice_grad.f90 -o matrice_grad.exe

! deux exemples d'allocation de memoire

! 1. programmation avec memoire statique

! parameter(N=100) ! matrice  NxN
! real x(N),xx(N),a(N,N),b(N)
! real gk(N),agk(N),dk(N),adk(N)
! real solg(N),solgc(N)

! 2. allocation dynamique de la memoire pour remplacer
! l'allocation statique

real, allocatable, dimension(:):: x,xx,b
real, allocatable, dimension(:,:):: a
real, allocatable, dimension(:):: gk,agk,dk,adk
real, allocatable, dimension(:):: solg,solgc

print *,'Taille matrice ?'
read(5,*) N

allocate(x(N))
allocate(xx(N))
allocate(b(N))
allocate(a(N,N))
allocate(gk(N))
allocate(agk(N))
allocate(dk(N))
allocate(adk(N))
allocate(solg(N))
allocate(solgc(N))

igc=1  ! gradient ou gradient conjugue
nbgrad=30 ! nbre iterations gradient

b(1:N)=0

open(1,file='matrix.dat',status='unknown')
do i=1,N
        x(i)=i
    do j=1,N
        a(i,j)=exp(-0.05*(i-j)**2)
		write(1,*) i,j,a(i,j)
    enddo
	    write(1,'()')
enddo
close(1)

! visualisation de matrix.dat avec gnuplot
! splot 'matrix.dat' w l

b=matmul(a,x)  !cible

!
!inversion par minimisation d'energie
! methode de gradient a x = b , il faut retrouver x
!
! initialisaiton

xx(1:N)=0

!if(igc.eq.0) then

do 1 iter=1,nbgrad

!gk=matmul(a,xx)-b

do i=1,N
        gk(i)=0
    do j=1,N
      gk(i)=gk(i)+a(i,j)*xx(j)
    enddo
          gk(i)=gk(i)-b(i)
enddo

!agk=matmul(a,gk)

do i=1,N
        agk(i)=0
    do j=1,N
      agk(i)=agk(i)+a(i,j)*gk(j)
    enddo
enddo

!gkgk=dot_product(gk,gk)
!agkgk=dot_product(agk,gk)

gkgk=0
agkgk=0
do i=1,N
   gkgk=gkgk+gk(i)**2
   agkgk=agkgk+agk(i)*gk(i)
enddo

alphak=gkgk/agkgk

! xx(1:N)=xx(1:N)-alphak*gk(1:N)

    do i=1,N
        xx(i)=xx(i)-alphak*gk(i)
    enddo

	print *,iter,gkgk

1 continue  !nbgrad

solg(1:N)=xx(1:N)

!endif ! igc=0

!if(igc.eq.1) then ! gradient conjugue

xx(1:N)=0
gk=matmul(a,xx)-b
dk(1:N)=gk(1:N)

do 2 iter=1,nbgrad

adk=matmul(a,dk)
gkgk=dot_product(gk,gk)
adkdk=dot_product(adk,dk)
alphak=gkgk/adkdk
xx(1:N)=xx(1:N)-alphak*dk(1:N)
gk(1:N)=gk(1:N)-alphak*adk(1:N)
gk1gk1=dot_product(gk,gk)
betak1=gk1gk1/gkgk
dk(1:N)=gk(1:N)+betak1*dk(1:N)

	print *,iter,gkgk

2 continue

solgc(1:N)=xx(1:N)

!endif !igc=1

	do i=1,N
	 print *,x(i),solg(i),solgc(i)
	enddo

! visu gnuplot :  plot 'sol_ggc.dat' w l,'sol_ggc.dat' u 1:3 w l,'sol_ggc.dat' u 1:4 w l

	open(1,file='sol_ggc.dat',status='unknown')
	 do i=1,N
	  write(1,*) i,x(i),solg(i),solgc(i)
	 enddo
	 close(1)

deallocate(x)
deallocate(xx)
deallocate(b)
deallocate(a)
deallocate(gk)
deallocate(agk)
deallocate(dk)
deallocate(adk)
deallocate(solg)
deallocate(solgc)

print *,'fin normal'

end


subroutine flaplace(u, t, n, m, it)
!   Solve Laplace's equation on a rectangular domain
!   with values at an equispaced grid of points.
!   Use the boundaries of the array u as the boundary conditions
!   Perform 'it' number of iterations on the values in u.
!   In each iteration set each value to the
!   average of its four neighbors
    implicit none
    integer, intent(in) :: n, m, it
!   Columns are listed first in in array shapes in Fortran.
    double precision, dimension(n, m), intent(inout) :: u
!   t is a preallocated temporary array.
    double precision, dimension(n-2, m-2), intent(inout) :: t
    integer i
    do i = 1, it
!       & is the line continuation character in Fortran.
!       Fortran supports array slice notation.
!       Indices for arrays start at 1.
!       The ranges indicated in the slices include the end points
!       of the range.
!       Column indices come before row indices.
        t = .25 * (u(1:n-2,2:m-1) +&
            u(3:n,2:m-1) + u(2:n-1,1:m-2) + u(2:n-1,3:m))
        u(2:n-1,2:m-1) = t
    enddo
end subroutine flaplace


!***********************************************************************
!                                                                      *
      SUBROUTINE ES(F, S2F, S3F)
!                                                                      *
!   Evaluate the sum of the series                                     *
!                                                                      *
!                       infinity      n              k                 *
!              S  (F) =   Sum     (-1)  exp (n*F) / n                  *
!               k        n = 0                                         *
!                                                                      *
!   for k = 2, 3 to machine precision. This is a utility subroutine,   *
!   called by SUBROUTINEs NUCPOT and NCHARG.                           *
!                                                                      *
!   Written by Farid A Parpia, at Oxford  Last revision: 28 Sep 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:47:25   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE), INTENT(IN) :: F
      REAL(DOUBLE), INTENT(OUT) :: S2F
      REAL(DOUBLE), INTENT(OUT) :: S3F
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: N
      REAL(DOUBLE) :: FASE, EN, OBN, ENF, TERM2, TERM3, S2LAST
!-----------------------------------------------
!
      N = 0
      S2F = 0.0D00
      S3F = 0.0D00
      FASE = 1.0D00
      N = N + 1
      EN = DBLE(N)
      OBN = 1.0D00/EN
      FASE = -FASE
      ENF = EXP(EN*F)
      TERM2 = FASE*ENF*OBN*OBN
      TERM3 = TERM2*OBN
      S2LAST = S2F
      S2F = S2F + TERM2
      S3F = S3F + TERM3
      DO WHILE(ABS(S2F) /= ABS(S2LAST))
         N = N + 1
         EN = DBLE(N)
         OBN = 1.0D00/EN
         FASE = -FASE
         ENF = EXP(EN*F)
         TERM2 = FASE*ENF*OBN*OBN
         TERM3 = TERM2*OBN
         S2LAST = S2F
         S2F = S2F + TERM2
         S3F = S3F + TERM3
      END DO
!
      RETURN
      END SUBROUTINE ES


function bvalu(t, coef, nctl, K, ideriv, s)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract bvalu is the generic 1D spline interpolant
  !              function. It is similar to the function of the same
  !              name from the tensbs library without the work arrays
  !
  !     Description of Arguments
  !     Input
  !     t       - Real, Knot vector. Length nctl+k
  !     coef    - Real, Array of b-sline coefficients  Size (nctl)
  !     nctl    - Integer, Number of control points
  !     k       - Integer, order of B-spline
  !     ideriv  - Integer, degree of derivatve to evaluate
  !     s       - Real, Position to evaluate
  !
  !     Ouput bvalu - Real, Evaluated point or derivative

  use precision
  implicit none

  ! Input
  integer         , intent(in)     :: k, nctl, ideriv
  real(kind=realType), intent(in)  :: s
  real(kind=realType), intent(in)  :: t(nctl+k)
  real(kind=realType), intent(in)  :: coef(nctl)

  ! Output
  real(kind=realType)              :: bvalu

  ! Working
  integer                          :: l, istart, ileft
  real(kind=realType)              :: B(k), Bd(ideriv+1,k)

  bvalu = 0.0

  ! Find knot span
  call findSpan(s, k, t, nctl, ileft)
  istart = ileft-k
  if (ideriv ==0) then ! Use basis function
     call basis(t, nctl, k, s, ileft, B)
     do l=1, k
        bvalu = bvalu + B(l)*coef(istart+l)
     end do
  else
     ! Evalute derivative basis functions up to depree specified by
     ! ideriv
     call derivBasis(t, nctl, k, s, ileft, ideriv, Bd)
     do l=1, k
        bvalu = bvalu + Bd(ideriv+1,l)*coef(istart+l)
     end do
  end if
end function bvalu

function b2val(u, v, idu, idv, tu, tv, nctlu, nctlv, ku, kv, coef)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract bvalu is the generic 2D spline interpolant
  !              function. It is similar to the function of the same
  !              name from the tensbs library without the work array
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, parametric position 1
  !     v       - Real, parametric position 2
  !     idu     - Integer, derivative in u to evaluate
  !     idv     - Integer, derivative in v to evaluate
  !     tu      - Real, U Knot vector. Length nctlu+ku
  !     tv      - Real, V Knot vector. Length nctlv+kv
  !     Nctlu   - Integer, Number of u control points
  !     Nctlv   - Integer, Number of v control points
  !     ku      - Integer, order of spline in u direction
  !     kv      - Integer, order of spline in v direction
  !     coef    - Real, Array size Nctlu x Nctlv, B-spline coefficients
  !
  !     Ouput
  !     b2val   - Real, Evaluated point or derivative

  use precision
  implicit none

  ! Input
  integer         , intent(in)     :: ku, kv, nctlu, nctlv, idu, idv
  real(kind=realType), intent(in)  :: u,v, tu(nctlu+ku), tv(nctlv+kv)
  real(kind=realType), intent(in)  :: coef(nctlu,nctlv)

  ! Output
  real(kind=realType)              :: b2val

  ! Working
  integer                          :: i, j
  integer                          :: ileftu, ileftv, istartu, istartv
  real(kind=realType)              :: Bu(ku), Bv(kv)
  real(kind=realType)              :: Bud(idu+1, ku), Bvd(idv+1, kv)

  ! Find knot spans
  call findSpan(u, ku, tu, nctlu, ileftu)
  istartu = ileftu-ku

  call findSpan(v, kv, tv, nctlv, ileftv)
  istartv = ileftv-kv

  b2val = 0.0

  ! Check if we can just use regular basis functions:
  if (idu + idv == 0) then
     call basis(tu, nctlu, ku, u, ileftu, Bu)
     call basis(tv, nctlv, kv, v, ileftv, Bv)

     do i=1, ku
        do j=1, kv
           b2val = b2val + Bu(i)*Bv(j)*coef(istartu+i, istartv+j)
        end do
     end do
  else
     ! We need derivative basis functions
     call derivBasis(tu, nctlu, ku, u, ileftu, idu, Bud)
     call derivBasis(tv, nctlv, kv, v, ileftv, idv, Bvd)

     do i=1, ku
        do j=1, kv
           b2val = b2val + Bud(idu+1,i)*Bvd(idv+1,j)*coef(istartu+i, istartv+j)
        end do
     end do
  end if

end function b2val

function b3val(u, v, w, idu, idv, idw, tu, tv, tw, nctlu, nctlv, nctlw, &
     ku, kv, kw, coef)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract bvalu is the generic 2D spline interpolant
  !              function. It is similar to the function of the same
  !              name from the tensbs library without the work array
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, parametric position 1
  !     v       - Real, parametric position 2
  !     w       - Real, parametric position 3
  !     idu     - Integer, derivative in u to evaluate
  !     idv     - Integer, derivative in v to evaluate
  !     idw     - Integer, derivative in w to evaluate
  !     tu      - Real, U Knot vector. Length nctlu+ku
  !     tv      - Real, V Knot vector. Length nctlv+kv
  !     tv      - Real, W Knot vector. Length nctlw+kw
  !     Nctlu   - Integer, Number of u control points
  !     Nctlv   - Integer, Number of v control points
  !     Nctlw   - Integer, Number of w control points
  !     ku      - Integer, order of spline in u direction
  !     kv      - Integer, order of spline in v direction
  !     kw      - Integer, order of spline in w direction
  !     coef    - Real, Array size Nctlu x Nctlv x Nctlw, B-spline coefficients
  !
  !     Ouput
  !     b3val   - Real, Evaluated point or derivative

  use precision
  implicit none

  ! Input
  integer         , intent(in)     :: ku, kv, kw, nctlu, nctlv, nctlw
  integer         , intent(in)     :: idu, idv, idw
  real(kind=realType), intent(in)  :: u, v, w
  real(kind=realType), intent(in)  :: tu(nctlu+ku), tv(nctlv+kv), tw(nctlw+kw)
  real(kind=realType), intent(in)  :: coef(nctlu,nctlv,nctlw)

  ! Output
  real(kind=realType)              :: b3val

  ! Working
  integer                          :: i, j, k
  integer                          :: ileftu, ileftv, ileftw
  integer                          :: istartu, istartv, istartw
  real(kind=realType)              :: Bu(ku), Bv(kv), Bw(kw)
  real(kind=realType)              :: Bud(idu+1, ku)
  real(kind=realType)              :: Bvd(idv+1, kv)
  real(kind=realType)              :: Bwd(idw+1, kw)

  ! Find knot spans
  call findSpan(u, ku, tu, nctlu, ileftu)
  istartu = ileftu-ku

  call findSpan(v, kv, tv, nctlv, ileftv)
  istartv = ileftv-kv

  call findSpan(w, kw, tw, nctlw, ileftw)
  istartw = ileftw-kw

  b3val = 0.0

  ! Check if we can just use regular basis functions:
  if (idu + idv + idw == 0) then
     call basis(tu, nctlu, ku, u, ileftu, Bu)
     call basis(tv, nctlv, kv, v, ileftv, Bv)
     call basis(tw, nctlw, kw, w, ileftw, Bw)

     do i=1, ku
        do j=1, kv
           do k=1, kw
              b3val = b3val + Bu(i)*Bv(j)*Bw(k)*&
                   coef(istartu+i, istartv+j, istartw+k)
           end do
        end do
     end do
  else
     ! We need derivative basis functions
     call derivBasis(tu, nctlu, ku, u, ileftu, idu, Bud)
     call derivBasis(tv, nctlv, kv, v, ileftv, idv, Bvd)
     call derivBasis(tw, nctlw, kw, w, ileftw, idw, Bwd)

     do i=1, ku
        do j=1, kv
           do k=1, kw
              b3val = b3val + Bud(idu+1, i)*Bvd(idv+1, j)*Bwd(idw+1, k) * &
                   coef(istartu+i, istartv+j, istartw+k)
           end do
        end do
     end do
  end if

end function b3val

! Also define complex versions --- these are only here for
! TACS. pySpline doesn't need them

function cbvalu(t, coef, nctl, K, ideriv, s)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract bvalu is the generic 1D spline interpolant
  !              function. It is similar to the function of the same
  !              name from the tensbs library without the work arrays
  !
  !     Description of Arguments
  !     Input
  !     t       - Real, Knot vector. Length nctl+k
  !     coef    - Complex, Array of b-sline coefficients  Size (nctl)
  !     nctl    - Integer, Number of control points
  !     k       - Integer, order of B-spline
  !     ideriv  - Integer, degree of derivatve to evaluate
  !     s       - Real, Position to evaluate
  !
  !     Ouput bvalu - Complex, Evaluated point or derivative

  use precision
  implicit none

  ! Input
  integer         , intent(in)        :: k, nctl, ideriv
  real(kind=realType), intent(in)     :: s
  real(kind=realType), intent(in)     :: t(nctl+k)
  complex(kind=realType), intent(in)  :: coef(nctl)

  ! Output
  complex(kind=realType)              :: cbvalu

  ! Working
  integer                          :: l, istart, ileft
  real(kind=realType)              :: B(k), Bd(k,k)

  cbvalu = cmplx(0.0, 0.0)

  ! Find knot span
  call findSpan(s, k, t, nctl, ileft)
  istart = ileft-k
  if (ideriv ==0) then ! Use basis function
     call basis(t, nctl, k, s, ileft, B)
     do l=1, k
        cbvalu = cbvalu + B(l)*coef(istart+l)
     end do
  else
     ! Evalute derivative basis functions up to depree specified by
     ! ideriv
     call derivBasis(t, nctl, k, s, ileft, ideriv, Bd)
     do l=1, k
        cbvalu = cbvalu + Bd(ideriv+1,l)*coef(istart+l)
     end do
  end if
end function cbvalu

function cb2val(u, v, idu, idv, tu, tv, nctlu, nctlv, ku, kv, coef)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract bvalu is the generic 2D spline interpolant
  !              function. It is similar to the function of the same
  !              name from the tensbs library without the work array
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, parametric position 1
  !     v       - Real, parametric position 2
  !     idu     - Integer, derivative in u to evaluate
  !     idv     - Integer, derivative in v to evaluate
  !     tu      - Real, U Knot vector. Length nctlu+ku
  !     tv      - Real, V Knot vector. Length nctlv+kv
  !     Nctlu   - Integer, Number of u control points
  !     Nctlv   - Integer, Number of v control points
  !     ku      - Integer, order of spline in u direction
  !     kv      - Integer, order of spline in v direction
  !     coef    - Complex, Array size Nctlu x Nctlv, B-spline coefficients
  !
  !     Ouput
  !     b2val   - Complex, Evaluated point or derivative

  use precision
  implicit none

  ! Input
  integer         , intent(in)        :: ku, kv, nctlu, nctlv, idu, idv
  real(kind=realType), intent(in)     :: u,v, tu(nctlu+ku), tv(nctlv+kv)
  complex(kind=realType), intent(in)  :: coef(nctlu,nctlv)

  ! Output
  complex(kind=realType)              :: cb2val

  ! Working
  integer                          :: i, j
  integer                          :: ileftu, ileftv, istartu, istartv
  real(kind=realType)              :: Bu(ku), Bv(kv)
  real(kind=realType)              :: Bud(ku, ku), Bvd(kv, kv)

  ! Find knot spans
  call findSpan(u, ku, tu, nctlu, ileftu)
  istartu = ileftu-ku

  call findSpan(v, kv, tv, nctlv, ileftv)
  istartv = ileftv-kv

  cb2val = cmplx(0.0, 0.0)

  ! Check if we can just use regular basis functions:
  if (idu + idv == 0) then
     call basis(tu, nctlu, ku, u, ileftu, Bu)
     call basis(tv, nctlv, kv, v, ileftv, Bv)

     do i=1, ku
        do j=1, kv
           cb2val = cb2val + Bu(i)*Bv(j)*coef(istartu+i, istartv+j)
        end do
     end do
  else
     ! We need derivative basis functions
     call derivBasis(tu, nctlu, ku, u, ileftu, idu, Bu)
     call derivBasis(tv, nctlv, kv, v, ileftv, idv, BV)

     do i=1, ku
        do j=1, kv
           cb2val = cb2val + Bud(idu+1,i)*Bvd(idv+1,j)*coef(istartu+i, istartv+j)
        end do
     end do
  end if

end function cb2val

function cb3val(u, v, w, idu, idv, idw, tu, tv, tw, nctlu, nctlv, nctlw, &
     ku, kv, kw, coef)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract bvalu is the generic 2D spline interpolant
  !              function. It is similar to the function of the same
  !              name from the tensbs library without the work array
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, parametric position 1
  !     v       - Real, parametric position 2
  !     w       - Real, parametric position 3
  !     idu     - Integer, derivative in u to evaluate
  !     idv     - Integer, derivative in v to evaluate
  !     idw     - Integer, derivative in w to evaluate
  !     tu      - Real, U Knot vector. Length nctlu+ku
  !     tv      - Real, V Knot vector. Length nctlv+kv
  !     tv      - Real, W Knot vector. Length nctlw+kw
  !     Nctlu   - Integer, Number of u control points
  !     Nctlv   - Integer, Number of v control points
  !     Nctlw   - Integer, Number of w control points
  !     ku      - Integer, order of spline in u direction
  !     kv      - Integer, order of spline in v direction
  !     kw      - Integer, order of spline in w direction
  !     coef    - Complex, Array size Nctlu x Nctlv x Nctlw, B-spline coefficients
  !
  !     Ouput
  !     b3val   - Complex, Evaluated point or derivative

  use precision
  implicit none

  ! Input
  integer         , intent(in)        :: ku, kv, kw, nctlu, nctlv, nctlw
  integer         , intent(in)        :: idu, idv, idw
  real(kind=realType), intent(in)     :: u, v, w
  real(kind=realType), intent(in)     :: tu(nctlu+ku), tv(nctlv+kv), tw(nctlw+kw)
  complex(kind=realType), intent(in)  :: coef(nctlu,nctlv,nctlw)

  ! Output
  complex(kind=realType)           :: cb3val

  ! Working
  integer                          :: i, j, k
  integer                          :: ileftu, ileftv, ileftw
  integer                          :: istartu, istartv, istartw
  real(kind=realType)              :: Bu(ku), Bv(kv), Bw(kw)
  real(kind=realType)              :: Bud(ku, ku), Bvd(kv, kv), Bwd(kw, kw)

  ! Find knot spans
  call findSpan(u, ku, tu, nctlu, ileftu)
  istartu = ileftu-ku

  call findSpan(v, kv, tv, nctlv, ileftv)
  istartv = ileftv-kv

  call findSpan(w, kw, tw, nctlw, ileftw)
  istartw = ileftw-kw

  cb3val = cmplx(0.0, 0.0)

  ! Check if we can just use regular basis functions:
  if (idu + idv + idw == 0) then
     call basis(tu, nctlu, ku, u, ileftu, Bu)
     call basis(tv, nctlv, kv, v, ileftv, Bv)
     call basis(tw, nctlw, kw, w, ileftw, Bw)

     do i=1, ku
        do j=1, kv
           do k=1, kw
              cb3val = cb3val + Bu(i)*Bv(j)*Bw(k)*&
                   coef(istartu+i, istartv+j, istartw+k)
           end do
        end do
     end do
  else
     ! We need derivative basis functions
     call derivBasis(tu, nctlu, ku, u, ileftu, idu, Bud)
     call derivBasis(tv, nctlv, kv, v, ileftv, idv, Bvd)
     call derivBasis(tw, nctlw, kw, w, ileftw, idw, Bwd)

     do i=1, ku
        do j=1, kv
           do k=1, kw
              cb3val = cb3val + Bud(idu+1, i)*Bvd(idv+1, j)*Bwd(idw+1, k) * &
                   coef(istartu+i, istartv+j, istartw+k)
           end do
        end do
     end do
  end if

end function cb3val


!> @brief This subroutine solves a REAL32 quadratic equation of the form "ax2 + bx + c = 0".
!>
!> @param[in] a The first coefficient
!>
!> @param[in] b The second coefficient
!>
!> @param[in] c The third coefficient
!>
!> @param[out] x1 The first solution
!>
!> @param[out] x2 The second solution
!>
!> @note For a concise explanation see https://people.csail.mit.edu/bkph/articles/Quadratics.pdf by B.K.P. Horn (see https://people.csail.mit.edu/bkph/).
!>

PURE SUBROUTINE sub_solve_quadratic_REAL32_equation(a, b, c, x1, x2)
    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    REAL(kind = REAL32), INTENT(in)                                             :: a
    REAL(kind = REAL32), INTENT(in)                                             :: b
    REAL(kind = REAL32), INTENT(in)                                             :: c
    REAL(kind = REAL32), INTENT(out)                                            :: x1
    REAL(kind = REAL32), INTENT(out)                                            :: x2

    ! Check sign of b ...
    IF(b >= 0.0e0_REAL32)THEN
        x1 = (-b - SQRT(b ** 2 - 4.0e0_REAL32 * a * c)) / (2.0e0_REAL32 * a)
        x2 = (2.0e0_REAL32 * c) / (-b - SQRT(b ** 2 - 4.0e0_REAL32 * a * c))
    ELSE
        x1 = (2.0e0_REAL32 * c) / (-b + SQRT(b ** 2 - 4.0e0_REAL32 * a * c))
        x2 = (-b + SQRT(b ** 2 - 4.0e0_REAL32 * a * c)) / (2.0e0_REAL32 * a)
    END IF
END SUBROUTINE sub_solve_quadratic_REAL32_equation


*       write program to find serivstive of f(x)=sin(x)
*       for x=1 , usimg 3 point method

 10     Read(*,*)X
        write(*,*)'Enter the value of H'
        Read(*,*)H
        If(H.LE.0)stop
        fbrime=(sin(x+H)-sin(x-H))/2*h
        exact=cos(x)
        Error=exact-fbrime
        write(*,*)H,Error,fbrime,exact
        Go to 10
*        Stop
        End


submodule (stdlib_specialfunctions) stdlib_specialfunctions_legendre
    implicit none

contains

    ! derivatives of legegendre polynomials
    ! unspecified behaviour if n is negative
    pure elemental module function dlegendre_fp64(n,x) result(dleg)
        integer, intent(in) :: n
        real(dp), intent(in) :: x
        real(dp) :: dleg

        select case(n)
            case(0)
                dleg = 0
            case(1)
                dleg = 1
            case default
                block
                    real(dp) :: leg_down1, leg_down2, leg
                    real(dp) :: dleg_down1, dleg_down2
                    integer :: i

                    leg_down1  = x
                    dleg_down1 = 1

                    leg_down2  = 1
                    dleg_down2 = 0

                    do i = 2, n
                        leg = (2*i-1)*x*leg_down1/i - (i-1)*leg_down2/i
                        dleg = dleg_down2 + (2*i-1)*leg_down1
                        leg_down2 = leg_down1
                        leg_down1 = leg
                        dleg_down2 = dleg_down1
                        dleg_down1 = dleg
                    end do
                end block
        end select
    end function

    ! legegendre polynomials
    ! unspecified behaviour if n is negative
    pure elemental module function legendre_fp64(n,x) result(leg)
        integer, intent(in) :: n
        real(dp), intent(in) :: x
        real(dp) :: leg
        select case(n)
            case(0)
                leg  = 1
            case(1)
                leg  = x
            case default
                block
                    real(dp) :: leg_down1, leg_down2
                    integer :: i

                    leg_down1  = x
                    leg_down2  = 1

                    do i = 2, n
                        leg = (2*i-1)*x*leg_down1/i - (i-1)*leg_down2/i
                        leg_down2 = leg_down1
                        leg_down1 = leg
                    end do
                end block
        end select
    end function

end submodule


! Calculating Pi with using method:
!     integral 4.0/(1+x^2) dx = p
! 	   OpenMP Version 2
program pi_omp_v1
implicit none
integer*8 :: num_steps = 1000000000
integer i,tid,nthreads,omp_get_num_threads,omp_get_thread_num
real*8 :: PI_ref=3.1415926535897932,step,x,pi
real*8 :: summation=0.0
real*8   :: start,finish,omp_get_wtime
!call cpu_time(start)
step = 1/(1.0 * num_steps)
start=omp_get_wtime()
!$omp parallel do private(x) reduction(+:summation) shared(step)
	do i =1,num_steps
		x=((i-1)+0.5) * step;
		summation=summation + (4.0/(1.0+(x*x)))
	end do
!$omp end parallel do
	pi=step*summation

!call cpu_time(finish)
finish=omp_get_wtime()
	write(*,*) "Estimated value of pi =",pi
	write(*,*) "Error =", abs(PI_ref - pi)
	write(*,*) "Compute time=", (finish-start)," seconds"
end


PROGRAM DERIVADAS
! CALL derivada(n,x,h,func,A) esta subrutina calcula con una presicion 'n', el valor 'A' de la derivada en un punto 'x' con un paso de 'h' de una funcion 'func'(definida como external antes del programa. todo con presicion doble

!-----------------------------------------------------------------------
	contains
! ----------------------------------------------------------------------
      subroutine derivada(n,x,h,func,A)
      !esta subrutina calcula con una presicion 'n', el valor 'A' de la derivada en un punto 'x' con un paso de 'h' de una funcion 'func'(definida como external antes del programa. todo con presicion doble
      implicit none
      real*8::h,x,A,func
      REAL*8,ALLOCATABLE,DIMENSION(:,:)::D
      integer*4::i,j,n

      allocate(D(n,n))
      D(:,:)=0.0d1
      !CADA fila es un D(fila ejemplo 1) con la primer cordenada 2H la segunda H la tercera H/2. la segunda fila es un D2 con primer elemento H segundo H/2 Y ASI
      do j=0,n-1
      do i=1,n-j
      if (j==0) then
      if (i==1) then
      D(j+1,i)=((func(x+h)-func(x-h))/(2*h))
      else
      D(j+1,i)=((func(x+(h/(2**(i-1))))-func(x-(h/(2**(i-1)))))/(2*(h/(2**(i-1)))))
      end if
      else
      D(j+1,i)=(((2**(2*(j))))*D(j,i+1)-D(j,i))/((2**(2*(j)))-1)
      end if
      end do
      end do
      A=D(n,1)
      deallocate(D)
      return
      end subroutine
END


C$Procedure      DVDOT  ( Derivative of Vector Dot Product, 3-D )

      DOUBLE PRECISION FUNCTION DVDOT ( S1, S2 )

C$ Abstract
C
C     Compute the derivative of the dot product of two double
C     precision position vectors.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C     DERIVATIVE
C
C$ Declarations

      DOUBLE PRECISION   S1 ( 6 )
      DOUBLE PRECISION   S2 ( 6 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     S1        I     First state vector in the dot product.
C     S2        I     Second state vector in the dot product.
C
C     The function returns the derivative of the dot product <S1,S2>
C
C$ Detailed_Input
C
C     S1      Any state vector.  The componets are in order
C             (x, y, z, dx/dt, dy/dt, dz/dt )
C
C     S2      Any state vector.
C
C$ Detailed_Output
C
C     The function returns the derivative of the dot product of the
C     position portions of the two state vectors S1 and S2.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Particulars
C
C     Given two state vectors S1 and S2 made up of position and
C     velocity components (P1,V1) and (P2,V2) respectively,
C     DVDOT calculates the derivative of the dot product of P1 and P2,
C     i.e. the time derivative
C
C           d
C           -- < P1, P2 > = < V1, P2 > + < P1, V2 >
C           dt
C
C     where <,> denotes the dot product operation.
C
C$ Examples
C
C     Suppose that given two state vectors (S1 and S2)whose position
C     components are unit vectors, and that we need to compute the
C     rate of change of the angle between the two vectors.
C
C     We know that the Cosine of the angle THETA between them is given
C     by
C
C        COSINE(THETA) = VDOT(S1,S2)
C
C     Thus by the chain rule, the derivative of the angle is given
C     by:
C
C        SINE(THETA) dTHETA/dt = DVDOT(S1,S2)
C
C     Thus for values of THETA away from zero we can compute
C
C     dTHETA/dt as
C
C     DTHETA = DVDOT(S1,S2) / SQRT ( 1 - VDOT(S1,S2)**2 )
C
C     Note that position components of S1 and S2 are parallel, the
C     derivative of the  angle between the positions does not
C     exist.  Any code that computes the derivative of the angle
C     between two position vectors should account for the case
C     when the position components are parallel.
C
C$ Restrictions
C
C     The user is responsible for determining that the states S1 and
C     S2 are not so large as to cause numeric overflow.  In most cases
C     this won't present a problem.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 18-MAY-1995 (WLT)
C
C
C-&

C$ Index_Entries
C
C     Compute the derivative of a dot product
C
C-&
C

      DVDOT = S1(1)*S2(4) + S1(2)*S2(5) + S1(3)*S2(6)
     .      + S1(4)*S2(1) + S1(5)*S2(2) + S1(6)*S2(3)

      RETURN
      END


!
! lab1_7.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
! MA 02110-1301, USA.
!
!
!
PROGRAM lab1_7

use precision, pr => dp
!include "/usr/include/fftw3.f"

IMPLICIT NONE

include "/usr/include/fftw3.f"
integer(kind=8) :: plan_rc, plan_cr

integer :: i, j, k
integer, parameter :: n=1024
real(pr) :: start_time, finish_time
real(pr) :: pi, ti, tf, L, factor, fre, fim
real(pr), dimension(n) :: f, t
complex(pr), dimension(n/2 + 1) :: f_hat

open(unit=10, file='f_t_ej7.dat', status='UNKNOWN', action='WRITE')
open(unit=16, file='fft_ej7.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#  t  f"
write(16, *) "#  freq  real  imag"
call dfftw_plan_dft_r2c_1d(plan_rc, n, f, f_hat, FFTW_MEASURE)

pi = 4._pr*atan(1._pr)
ti = 0._pr
tf = 4._pr
L = (tf - ti)

t(1:n) = (/ (i, i=1, n) /)
t = t*L/real(n, pr)

f = sin(pi/2._pr * t) + cos(20._pr * pi * t)
do i=1, n
    write(10, *) t(i), f(i)
end do

call cpu_time(start_time)

call dfftw_execute_dft_r2c(plan_rc, f, f_hat)

call cpu_time(finish_time)

!write(16,*) '#   freq     f_hat'
factor = 1024._pr / L

do i = -n/2, n/2, 1
    if (i < 0) then
        fre = real(conjg(f_hat(-i+1) )/real(n, pr))
        fim = imag(conjg(f_hat(-i+1) )/real(n, pr))
        write(16,*) factor*real(i, pr),  fre, fim
    else
        fre = real(f_hat(i+1) /real(n, pr))
        fim = imag(f_hat(i+1) /real(n, pr))
        write(16,*) factor*real(i, pr), fre, fim
    endif
enddo

END PROGRAM lab1_7


double precision function lngamma(z)
!       Uses Lanczos-type approximation to ln(gamma) for z > 0.
!       Reference:
!            Lanczos, C. 'A precision approximation of the gamma function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
!       Accuracy: About 14 significant digits except for small regions in the vicinity of 1 and 2.
!
!       Programmer: Alan Miller
!                   1 Creswick Street, Brighton, Vic. 3187, Australia
!       Latest revision - 17 April 1988
    implicit none
    double precision a(9), z, lnsqrt2pi, tmp
    integer j
    data a/0.9999999999995183d0, 676.5203681218835d0,  -1259.139216722289d0, 771.3234287757674d0,&
              -176.6150291498386d0, 12.50734324009056d0, -0.1385710331296526d0, 0.9934937113930748d-05,&
              0.1659470187408462d-06/

    data lnsqrt2pi/0.9189385332046727d0/

    if (z <= 0.d0) return

    lngamma = 0.d0
    tmp = z + 7.d0
    do j = 9, 2, -1
        lngamma = lngamma + a(j)/tmp
        tmp = tmp - 1.d0
    end do
    lngamma = lngamma + a(1)
    lngamma = log(lngamma) + lnsqrt2pi - (z+6.5d0) + (z-0.5d0)*log(z+6.5d0)
end

subroutine get_xgwg(x1, x2, x, w, n)
    ! gauleg.f90     P145 Numerical Recipes in Fortran
    ! compute x(i) and w(i)  i=1,n  Gauss-Legendre ordinates and weights
    ! on interval -1.0 to 1.0 (length is 2.0)
    ! use ordinates and weights for Gauss Legendre integration
    ! After f2py implicit argument wrapping: x, w = get_xgwg(x1, x2, n)
  implicit none
  integer, intent(in) :: n
  double precision, intent(in) :: x1, x2
  double precision, dimension(n), intent(out) :: x, w
  integer :: i, j, m
  double precision :: p1, p2, p3, pp, xl, xm, z, z1
  double precision, parameter :: eps=1.d-15

  m = (n+1)/2
  xm = 0.5d0*(x2+x1)
  xl = 0.5d0*(x2-x1)
  do i=1,m
    z = cos(3.141592654d0*(i-0.25d0)/(n+0.5d0))
    z1 = 0.d0
    do while(abs(z-z1) > eps)
      p1 = 1.0d0
      p2 = 0.0d0
      do j=1,n
        p3 = p2
        p2 = p1
        p1 = ((2.0d0*j-1.0d0)*z*p2-(j-1.0d0)*p3)/j
      end do
      pp = n*(z*p1-p2)/(z*z-1.0d0)
      z1 = z
      z = z1 - p1/pp
    end do
    x(i) = xm - xl*z
    x(n+1-i) = xm + xl*z
    w(i) = (2.0d0*xl)/((1.0d0-z*z)*pp*pp)
    w(n+1-i) = w(i)
  end do
end subroutine get_xgwg

subroutine wignerpos(xi, cl, x, m1, m2, nx, lmax)
    ! Position-space representation
    ! sum_l Cl (2l + 1) / 4pi d^l_{m1,m2}(x)
    implicit None
    integer, intent(in) :: m1, m2, lmax, nx
    double precision, intent(in) :: x(nx), cl(0:lmax)
    double precision, intent(out) ::  xi(nx)
    double precision :: d0(nx), d1(nx), d2(nx)
    double precision, external :: lngamma
    integer :: a, b, lmin, n, in, sgn
    double precision :: alfbet, a2, b2, n2_ab2, norm, a0, ak_km1, akm1_km2

    lmin = max(abs(m1), abs(m2))
    a = abs(m1 - m2)
    b = abs(m1 + m2)
    if (m1 > m2) then
        sgn = (-1) ** (m1 - m2)
    else
        sgn = 1
    end if
    n = max(lmax, lmin) - lmin
    alfbet= a + b
    a2 = a * a
    b2 = b * b

    a0 = exp(0.5d0 * (lngamma(2d0 * lmin + 1d0) - lngamma(a + 1d0) - lngamma(2 * lmin - a + 1d0)))
    ak_km1 = sqrt((1.d0 + 2 * lmin) / (1.d0 + a) / (1.d0 + b))
    !  a1 / a0. (ak is coefficient relating Jacobi to Wigner)
    ! lmin
    d0 = sgn * a0 * ((1.d0 - x) * 0.5d0) ** (0.5d0 * a) * ((1. + x) * 0.5d0) ** (b * 0.5d0)
    xi = (2 * lmin + 1) * cl(lmin) * d0
    if (n > 0) then
        ! lmin + 1
        d1 = ak_km1 * d0 * 0.5d0 * (2 * (a + 1) +  (alfbet + 2d0) * (x - 1d0))
        xi = xi + (2 * lmin + 3) * cl(lmin + 1) * d1
    end if
    do in = 1, n -1
        akm1_km2 = ak_km1
        ak_km1 = sqrt((1d0 + lmin * 2d0 / (in + 1d0)) / (1d0 + a / (in + 1d0)) / (1d0 + b/(in + 1d0)))
        n2_ab2 = 2 * in + alfbet
        norm = 2 * (in + 1) * (in + 1 + alfbet) * n2_ab2
        !lmin + in + 1
        d2 = (((n2_ab2 + 1.d0) * ((n2_ab2 + 2.d0) * n2_ab2 * x + a2 - b2)) * ak_km1 * d1 &
        - 2 * ( in + a) * (in + b) * (n2_ab2 + 2d0) * akm1_km2 * ak_km1 * d0) / norm
        xi = xi + (2 * (lmin + in + 1) + 1) * cl(lmin + in + 1) * d2
        d0 = d1
        d1 = d2
    end do
    xi = xi * (0.25d0 / 3.14159265358979323846d0)
end subroutine wignerpos

subroutine wignercoeff(h, xiw, x, m1, m2, lmax, nx)
    ! Returns 2pi * sum_i xiw[i] d^l_{m1, m2}(x_i) for 0 <= l <= lmax.
    ! If xiw is the product of Gauss-Legend quadrature weights, x the GL quadrature points,
    ! then this is  the Wigner transform harmonic coefficient cl = 2pi \int_{-1}^{1} dx d^l_{m1,m2}(x) xi(x),
    ! with xi(x) = sum_l cl (2l + 1) / 4pi d^l_{m1, m2}.

    implicit None
    integer, intent(in) :: lmax, nx, m1, m2
    double precision, intent(in) :: x(nx), xiw(nx)
    double precision, intent(out) :: h(0:lmax)
    double precision :: d0(nx), d1(nx), d2(nx)
    double precision, external :: lngamma
    integer :: a, b, lmin, n, in, sgn
    double precision :: alfbet, a2, b2, n2_ab2, norm, a0, ak_km1, akm1_km2
    lmin = max(abs(m1), abs(m2))
    a = abs(m1 - m2)
    b = abs(m1 + m2)
    if (m1 > m2) then
        sgn = (-1) ** (m1 - m2)
    else
        sgn = 1
    end if
    n = max(lmax, lmin) - lmin
    n = max(Lmax, lmin) - lmin

    alfbet= a + b
    a2 = a * a
    b2 = b * b

    a0 = exp(0.5d0 * (lngamma(2d0 * lmin + 1d0) - lngamma(a + 1d0) - lngamma(2 * lmin - a + 1d0)))
    ak_km1 = sqrt((1.d0 + 2 * lmin) / (1.d0 + a) / (1.d0 + b))
    !  a1 / a0. (ak is coefficient relating Jacobi to Wigner)
    ! lmin
    d0 = sgn * a0 * ((1.d0 - x) * 0.5d0) ** (0.5d0 * a) * ((1. + x) * 0.5d0) ** (b * 0.5d0)
    h(lmin) = sum(xiw * d0)
    if (n > 0) then
        ! lmin + 1
        d1 = ak_km1 * d0 * 0.5d0 * (2 * (a + 1) +  (alfbet + 2d0) * (x - 1d0))
        h(lmin + 1) = sum(xiw * d1)
    end if
    do in = 1, n -1
        akm1_km2 = ak_km1
        ak_km1 = sqrt((1d0 + lmin * 2d0 / (in + 1d0)) / (1d0 + a / (in + 1d0)) / (1d0 + b/(in + 1d0)))
        n2_ab2 = 2 * in + alfbet
        norm = 2 * (in + 1) * (in + 1 + alfbet) * n2_ab2
        !lmin + in + 1
        d2 = (((n2_ab2 + 1.d0) * ((n2_ab2 + 2.d0) * n2_ab2 * x + a2 - b2)) * ak_km1 * d1 &
        - 2 * ( in + a) * (in + b) * (n2_ab2 + 2d0) * akm1_km2 * ak_km1 * d0) / norm
        h(lmin + in + 1) = sum(xiw * d2)
        d0 = d1
        d1 = d2
    end do
    h = h *  (2d0 * 3.14159265358979323846d0)

end subroutine wignercoeff


module slf_threshold

  use iso_fortran_env, only: r64 => real64
  implicit none

  real(r64), parameter, private :: pi = 4*atan(real(1,r64))

contains

  elemental real(r64) function THRSTEP(x) result(y)
    real(r64), intent(in) :: x
    if ( x .ge. 0 ) then
      y = 1.
    else
      y = 0.
    end if
  end function

  elemental real(r64) function THRLIN(x) result(y)
    real(r64), intent(in) :: x
    if ( x < -0.5_r64) then
      y = 0
    elseif ( x > 0.5_r64) then
      y = 1
    else
      y = x + 0.5_r64
    end if
  end function

  elemental real(r64) function THR2POLY(x,ord) result(y)
    real(r64), intent(in) :: x
    integer, intent(in), optional :: ord
    integer :: n
    real(r64) :: a, b

    n = 3
    if ( present(ord) )   n = ord

    a = THRLIN(0.5 + 2*x/n)
    b = THRLIN(0.5 - 2*x/n)

    y = (a**n - b**n + 1) / 2
  end function

  elemental real(r64) function THR4POLY(x,ord) result(y)
    real(r64), intent(in) :: x
    integer, intent(in), optional :: ord
    integer :: n
    real(r64) :: a, b, c

    n = 3
    if ( present(ord) )   n = ord

    a = THRLIN((3 + x*4)/2)
    b = 2*THRLIN(x) - 1
    c = THRLIN((3 - x*4)/2)

    y = (a**n - c**n + b*(2*n - abs(b)**(n-1)) + 2*n)/(4*n)

  end function

  elemental real(r64) function THRSIN(x) result(y)
    real(r64), intent(in) :: x
    real(r64) :: z

    z = 2*THRLIN(x / 2) - 1
    y =  (sin( pi * z) / pi + z + 1) / 2
  end function

  elemental real(r64) function THRATAN(x) result(y)
    real(r64), intent(in) :: x
    y = atan(x*pi) / pi + 0.5
  end function

  elemental real(r64) function thrsqrt(x) result(y)
    real(r64), intent(in) :: x
    y = 0.5_r64 +  x / sqrt( 1 + 4 * x**2 )
  end function

  elemental real(r64) function thrtanh(x) result(y)
    real(r64), intent(in) :: x
    y = 1d0 / ( 1d0 + exp(-4*x) )
  end function

end module

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

module slf_ramps

  use iso_fortran_env, only: r64 => real64
  implicit none

contains

  !----------------------------------------------------------------------------!
  ! this is a linear ramp

  elemental function ramp1(i,n) result(y)
    integer, intent(in) :: i,n
    real(r64) :: y
    y = real(max(min(i, n), 0), r64) / n
  end function

  !----------------------------------------------------------------------------!
  ! this is a very steep ramp, for later iterations

  elemental function ramp2(i,n) result(y)
    integer, intent(in) :: i,n
    real(r64) :: t,y
    t = real(max(min(i, n), 0), r64) / n
    y = t * (2 - t)
  end function

  !----------------------------------------------------------------------------!
  ! this is a very smooth, s-shaped ramp
  ! slow convergence but good if we are away from the solution

  elemental function ramp3(i,n) result(y)
    integer, intent(in) :: i,n
    real(r64) :: t,y
    t = real(max(min(i, n), 0), r64) / n
    y = (3 - 2*t) * t**2
  end function

  !----------------------------------------------------------------------------!
  ! this is a very smooth ramp where you can control the starting
  ! level as well as slope of the starting point. It may be applied
  ! for very unstable equations (A = 0, B = 0) or for a very quick
  ! convergence (A = 0.25, B = 1)

  elemental real(r64) function ramp4r(x, A, B) result(y)
    real(r64), intent(in) :: x
    real(r64), intent(in) :: A,B
    y = A + (1 - A) * B * x           &
    + 3 * (A - 1) * (B - 2) * x**2  &
    - (A - 1) * (3*B - 8) * x**3    &
    + (A - 1) * (B - 3) * x**4
  end function

  elemental function ramp4(i,n,A,B) result(y)
    integer, intent(in) :: i,n
    real(r64), intent(in) :: A,B
    real(r64) :: x,y
    x = real(max(min(i, n), 0), r64) / n
    y = ramp4r(x, A, B)
  end function

  !----------------------------------------------------------------------------!
  ! this ramp starts smoothly, rises rapidly, and then slowly saturates to 1

  elemental real(r64) function ramp5r(x) result(y)
    real(r64), intent(in) :: x
    y = (6 + x * (x * 3 - 8)) * x**2
  end function

  elemental function ramp5(i,n) result(y)
    integer, intent(in) :: i,n
    real(r64) :: t,y
    t = real(max(min(i, n), 0), r64) / n
    y = ramp5r(t)
  end function

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

  elemental real(r64) function ramp6r(x) result(y)
    real(r64), intent(in) :: x
    y = x**2 * (5 + x * (10 + x * (x * 8 - 20))) / 3
  end function

  elemental function ramp6(i,n) result(y)
    integer, intent(in) :: i,n
    real(r64) :: t,y
    t = real(max(min(i, n), 0), r64) / n
    y = ramp6r(t)
  end function

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

end module slf_ramps


program main

use test, only: test_value
use io, only: stdout

use algebra

implicit none

integer :: ierr, nrot
double precision :: vec1(3), vec2(3), vector_6(6), mat1(3,3), mat2(3,3)
double precision :: dot, cross(3)
double precision :: mean_value, stdev_value, coefvar_value

! subroutine normalize()
vec1(1) =   8.6d0
vec1(2) = -14.9d0
vec1(3) =   3.2d0
call normalize(vec1)
call test_value(vec1(1), 0.49146066786720721d0,'normalize(): component 1')
call test_value(vec1(2),-0.85148418037457996d0,'normalize(): component 2')
call test_value(vec1(3), 0.18286908571803062d0,'normalize(): component 3')
write(stdout,*) 'subroutine normalize() passed unit test'
write(stdout,*)

! subroutine dot_product()
vec1(1) =  18.6d0
vec1(2) = -34.7d0
vec1(3) =  -6.6d0
vec2(1) =  15.4d0
vec2(2) =   0.7d0
vec2(3) =   9.0d0
call dot_product(vec1,vec2,dot)
call test_value(dot,202.75000000000003d0,'dot_product()')
write(stdout,*) 'subroutine dot_product() passed unit test'
write(stdout,*)

! subroutine cross_product()
call cross_product(vec1,vec2,cross)
call test_value(cross(1),-307.68000000000001d0,'cross_product(): component 1')
call test_value(cross(2),-269.04000000000002d0,'cross_product(): component 2')
call test_value(cross(3), 547.40000000000009d0,'cross_product(): component 3')
write(stdout,*) 'subroutine cross_product() passed unit test'
write(stdout,*)

! subroutine rotate_vector_angle_axis(vec_in,angle,axis,vec_out,ierr)
vec1(1) = -0.34d0
vec1(2) =  0.75d0
vec1(3) = -0.06d0
call rotate_vector_angle_axis(vec1,  32.0d0,'x',vec2,ierr)
call test_value(vec2(1),               -0.34d0,'rotate_vector_angle_axis(): x-axis: component 1')
call test_value(vec2(2), 0.66783122797131178d0,'rotate_vector_angle_axis(): x-axis: component 2')
call test_value(vec2(3), 0.34655656240551813d0,'rotate_vector_angle_axis(): x-axis: component 3')
call rotate_vector_angle_axis(vec1,-249.2d0,'y',vec2,ierr)
call test_value(vec2(1), 6.4646826635005955d-2,'rotate_vector_angle_axis(): y-axis: component 1')
call test_value(vec2(2),                0.75d0,'rotate_vector_angle_axis(): y-axis: component 2')
call test_value(vec2(3), 0.33914714771913312d0,'rotate_vector_angle_axis(): y-axis: component 3')
call rotate_vector_angle_axis(vec1, 106.1d0,'z',vec2,ierr)
call test_value(vec2(1),-0.62629738349538722d0,'rotate_vector_angle_axis(): z-axis: component 1')
call test_value(vec2(2),-0.53465090239036517d0,'rotate_vector_angle_axis(): z-axis: component 2')
call test_value(vec2(3),               -0.06d0,'rotate_vector_angle_axis(): z-axis: component 3')
write(stdout,*) 'subroutine rotate_vector_angle_axis() passed unit test'
write(stdout,*)

! subroutine rotate_matrix_angle_axis(matrix_in,angle,axis,matrix_out,ierr)
mat1(1,1) =  -4.1065187541649522d0
mat1(1,2) =   1.7393039774189756d0
mat1(1,3) =  -7.5180411049161950d0
mat1(2,1) =   4.2831518746279666d0
mat1(2,2) =   6.9335695426045376d0
mat1(2,3) =  -7.4966824230646907d0
mat1(3,1) =   3.2585177718455043d0
mat1(3,2) =   5.9082031688210321d0
mat1(3,3) = -0.82932751247140502d0
call rotate_matrix_angle_axis(mat1,158.20628169005411d0,'x',mat2,ierr)
call test_value(mat2(1,1),-4.1065187541649522d0,'rotate_matrix_angle_axis(): x-axis: (1,1)')
call test_value(mat2(1,2), 1.1762034338405825d0,'rotate_matrix_angle_axis(): x-axis: (1,2)')
call test_value(mat2(1,3), 7.6264451655602041d0,'rotate_matrix_angle_axis(): x-axis: (1,3)')
call test_value(mat2(2,1),-5.1867971579695755d0,'rotate_matrix_angle_axis(): x-axis: (2,1)')
call test_value(mat2(2,2), 5.3159466459258233d0,'rotate_matrix_angle_axis(): x-axis: (2,2)')
call test_value(mat2(2,3),-9.9538352315436462d0,'rotate_matrix_angle_axis(): x-axis: (2,3)')
call test_value(mat2(3,1),-1.4354313960063656d0,'rotate_matrix_angle_axis(): x-axis: (3,1)')
call test_value(mat2(3,2), 3.4510503603420775d0,'rotate_matrix_angle_axis(): x-axis: (3,2)')
call test_value(mat2(3,3),0.78829538420731038d0,'rotate_matrix_angle_axis(): x-axis: (3,3)')
call rotate_matrix_angle_axis(mat1,12.976505091183620d0,'y',mat2,ierr)
call test_value(mat2(1,1),-4.8733275833542962d0,'rotate_matrix_angle_axis(): y-axis: (1,1)')
call test_value(mat2(1,2), 3.0215818039024152d0,'rotate_matrix_angle_axis(): y-axis: (1,2)')
call test_value(mat2(1,3),-6.5861566427086036d0,'rotate_matrix_angle_axis(): y-axis: (1,3)')
call test_value(mat2(2,1), 2.4903785677930772d0,'rotate_matrix_angle_axis(): y-axis: (2,1)')
call test_value(mat2(2,2), 6.9335695426045376d0,'rotate_matrix_angle_axis(): y-axis: (2,2)')
call test_value(mat2(2,3),-8.2670219500430164d0,'rotate_matrix_angle_axis(): y-axis: (2,3)')
call test_value(mat2(3,1), 4.1904022340530958d0,'rotate_matrix_angle_axis(): y-axis: (3,1)')
call test_value(mat2(3,2), 5.3667575324639163d0,'rotate_matrix_angle_axis(): y-axis: (3,2)')
call test_value(mat2(3,3),-6.2518683282060783d-2,'rotate_matrix_angle_axis(): y-axis: (3,3)')
call rotate_matrix_angle_axis(mat1,296.12107901952908d0,'z',mat2,ierr)
call test_value(mat2(1,1), 7.1742833398756733d0,'rotate_matrix_angle_axis(): z-axis: (1,1)')
call test_value(mat2(1,2), 1.2484031956652555d0,'rotate_matrix_angle_axis(): z-axis: (1,2)')
call test_value(mat2(1,3),-10.040978097812472d0,'rotate_matrix_angle_axis(): z-axis: (1,3)')
call test_value(mat2(2,1), 3.7922510928742463d0,'rotate_matrix_angle_axis(): z-axis: (2,1)')
call test_value(mat2(2,2),-4.3472325514360870d0,'rotate_matrix_angle_axis(): z-axis: (2,2)')
call test_value(mat2(2,3), 3.4496301608646154d0,'rotate_matrix_angle_axis(): z-axis: (2,3)')
call test_value(mat2(3,1), 6.7393988148516133d0,'rotate_matrix_angle_axis(): z-axis: (3,1)')
call test_value(mat2(3,2),-0.32450942648333436d0,'rotate_matrix_angle_axis(): z-axis: (3,2)')
call test_value(mat2(3,3),-0.82932751247140502d0,'rotate_matrix_angle_axis(): z-axis: (3,3)')
write(stdout,*) 'subroutine rotate_matrix_angle_axis() passed unit test'
write(stdout,*)

! subroutine jacobi(a,n,np,d,v,nrot,ierr)
! subroutine eig_sort(d,v,n,np)
mat1(1,1) = -2.2833110157453653d0
mat1(2,2) = -11.608231238033319d0
mat1(3,3) =  8.4575844946838608d0
mat1(1,2) =  6.6226220737607093d0
mat1(1,3) =  6.4092119904680871d0
mat1(2,3) = -4.3740580973518988d0
mat1(2,1) = mat1(1,2)
mat1(3,1) = mat1(1,3)
mat1(3,2) = mat1(2,3)
call jacobi(mat1,3,3,vec1,mat2,nrot,ierr)
call eig_sort(vec1,mat2,3,3)
if (mat2(1,1).gt.0.0d0) then
    mat2(1,1) = -mat2(1,1)
    mat2(2,1) = -mat2(2,1)
    mat2(3,1) = -mat2(3,1)
endif
if (mat2(1,2).lt.0.0d0) then
    mat2(1,2) = -mat2(1,2)
    mat2(2,2) = -mat2(2,2)
    mat2(3,2) = -mat2(3,2)
endif
if (mat2(1,3).lt.0.0d0) then
    mat2(1,3) = -mat2(1,3)
    mat2(2,3) = -mat2(2,3)
    mat2(3,3) = -mat2(3,3)
endif
call test_value(vec1(1),-16.939897642693150d0,'jacobi(): eigenvalue 1')
call test_value(vec1(2),-1.2480176224910310d-2,'jacobi(): eigenvalue 2')
call test_value(vec1(3),11.518420059823237d0,'jacobi(): eigenvalue 3')
call test_value(mat2(1,1),-0.49130341155129770d0,'jacobi(): eigenvector 1, component 1')
call test_value(mat2(2,1), 0.82912602200394458d0,'jacobi(): eigenvector 1, component 2')
call test_value(mat2(3,1), 0.26677892989134439d0,'jacobi(): eigenvector 1, component 3')
call test_value(mat2(1,2), 0.77537716392007883d0,'jacobi(): eigenvector 2, component 1')
call test_value(mat2(2,2), 0.55587251633836765d0,'jacobi(): eigenvector 2, component 2')
call test_value(mat2(3,2),-0.29965980586476104d0,'jacobi(): eigenvector 2, component 3')
call test_value(mat2(1,3), 0.39675081785588218d0,'jacobi(): eigenvector 3, component 1')
call test_value(mat2(2,3),-5.9630405126627532d-2,'jacobi(): eigenvector 3, component 2')
call test_value(mat2(3,3), 0.91598744713839986d0,'jacobi(): eigenvector 3, component 3')
write(stdout,*) 'subroutines jacobi() and eig_sort() passed unit test'
write(stdout,*)

! subroutine mean()
! subroutine stdev()
! subroutine coefvar()
vector_6(1) =  727.7d0
vector_6(2) = 1086.5d0
vector_6(3) = 1091.0d0
vector_6(4) = 1361.3d0
vector_6(5) = 1490.5d0
vector_6(6) = 1956.1d0
mean_value = mean(vector_6,6,ierr)
stdev_value = stdev(vector_6,6,ierr)
coefvar_value = coefvar(vector_6,6,ierr)
call test_value(mean_value,1285.5166666666667d0,'mean')
call test_value(stdev_value,420.96248961952256d0,'stdev')
call test_value(coefvar_value,0.32746560237999445d0,'coefvar')
write(stdout,*) 'functions mean(), stdev(), and coefvar() passed unit test'
write(stdout,*)

write(stdout,*) 'algebra_module unit test passed'
end


MODULE ylm_module ! Spherical Harmonic Function

  implicit none

  PRIVATE
  PUBLIC :: Ylm
  PUBLIC :: ZYlm

CONTAINS

  FUNCTION Ylm( x,y,z, L, M_in )

    implicit none
    real(8) :: Ylm
    real(8),intent(IN) :: x,y,z
    integer,intent(IN) :: L,M_in
    integer :: k1,k2,k,M
    real(8) :: r,r2,Clm,ct,phi,c,pi4
    real(8),parameter :: ep=1.d-10, zero=0.0d0
    real(8),parameter :: half=0.5d0, one=1.0d0, two=2.0d0
    real(8),parameter :: pi=3.141592653589793238d0

    Ylm = zero
    M   = abs(M_in)
    pi4 = 4.0d0*pi

    if ( L < 0 .or. M > L ) then
       write(*,*) "L,M_in=",L,M_in
       stop "Bad arguments (stop at Ylm)"
    end if

    if ( L == 0 ) then
       Ylm=one/sqrt(pi4)
       return
    end if

    if ( x == 0.0d0 .and. y == 0.0d0 .and. z == 0.0d0 ) return

    c=one
    do k=L-M+1,L+M
       c=c*dble(k)
    end do
    Clm=sqrt((two*L+one)/(c*pi4))

    r  = sqrt(x*x+y*y+z*z)
    ct = z/r
    if ( abs(x) < ep ) then
       phi = half*pi*sign(one,y)
    else
       phi = atan(y/x)
       if ( x < 0 ) phi = phi + pi
    end if

    if ( M_in > 0 ) then

       Ylm = sqrt(two)*Clm*Plm(L,M,ct)*cos(phi*M)

    else if ( M_in == 0 ) then

       Ylm = Clm*Plm(L,M,ct)

    else if ( mod(M,2) == 0 ) then

       Ylm =-sqrt(two)*Clm*Plm(L,M,ct)*sin(phi*M)

    else

       Ylm = sqrt(two)*Clm*Plm(L,M,ct)*sin(phi*M)

    end if

    return
  END FUNCTION Ylm

  FUNCTION ZYlm( x,y,z, L, M_in )

    implicit none
    complex(8) :: ZYlm
    real(8),intent(IN) :: x,y,z
    integer,intent(IN) :: L,M_in
    integer :: k1,k2,k,M
    real(8) :: r,r2,Clm,ct,phi,c,pi4
    real(8),parameter :: ep=1.d-10
    real(8),parameter :: half=0.5d0, one=1.0d0, two=2.0d0
    real(8),parameter :: pi=3.141592653589793238d0
    complex(8),parameter :: zero=(0.0d0,0.0d0)

    ZYlm = zero
    M    = abs(M_in)
    pi4  = 4.0d0*pi

    if ( L < 0 .or. M > L ) then
!       write(*,*) "L,M_in=",L,M_in
!       stop "Bad arguments (stop at ZYlm)"
       return
    end if

    if ( L == 0 ) then
       ZYlm=one/sqrt(pi4)
       return
    end if

    if ( x == 0.0d0 .and. y == 0.0d0 .and. z == 0.0d0 ) return

    c=one
    do k=L-M+1,L+M
       c=c*dble(k)
    end do
    Clm=sqrt((two*L+one)/(c*pi4))

    r  = sqrt(x*x+y*y+z*z)
    ct = z/r
    if ( abs(x) < ep ) then
       phi = half*pi*sign(one,y)
    else
       phi = atan(y/x)
       if ( x < 0 ) phi = phi + pi
    end if

    ZYlm = Clm*Plm(L,M,ct)*dcmplx( cos(phi*M), sin(phi*M) )

    if ( M_in < 0 ) then
       ZYlm = conjg( ZYlm )
       if ( mod(M,2) /= 0 ) ZYlm=-ZYlm
    end if

    return
  END FUNCTION ZYlm

!----------------------------------- Associated Legendre Polynomial Plm(x)

  FUNCTION Plm(L,M,xi)

    implicit none
    real(8) :: Plm
    integer,intent(IN) :: L,M
    real(8),intent(IN) :: xi
    real(8),parameter :: ep=1.d-13,one=1.0d0,two=2.0d0
    real(8) :: pmm,somx2,fact,pmmp1,pll,tmp,x
    integer :: i,ll

    x = xi
    tmp = abs(abs(x)-one) ; if ( tmp < ep ) x = sign(one,x)

    if( m < 0 .or. m > l .or. abs(x) > one ) then
       stop "Bad arguments (stop at Plm)"
    end if

    pmm=one

    if ( m > 0 ) then
       somx2=sqrt((one-x)*(one+x))
       fact=one
       do i=1,M
          pmm=-pmm*fact*somx2
          fact=fact+two
       end do
    end if

    if ( L == M ) then
       Plm = pmm
    else
       pmmp1 = x*(two*m+one)*pmm
       if ( L == M+1 ) then
          Plm=pmmp1
       else
          do ll=M+2,L
             pll=(x*(two*ll-one)*pmmp1-(ll+M-one)*pmm)/(ll-M)
             pmm=pmmp1
             pmmp1=pll
          end do
          Plm=pll
       end if
    end if

    return
  END FUNCTION Plm

END MODULE ylm_module