!>
module MathConstants
    use PrecisionMod, only: MK, SP
    implicit none
    real(MK), parameter :: eps           = 2.220446049250313e-16_MK
    ! Pi related
    real(MK), parameter :: pi            = 3.141592653589793238462643383279502884197169399375105820974944_MK
    real(MK), parameter :: pi_half       = 1.570796326794896619231321691639751442098584699687552910487472_MK
    real(MK), parameter :: twopi         = 6.283185307179586476925286766559005768394338798750211641949889_MK
    real(MK), parameter :: fourpi        = 12.56637061435917295385057353311801153678867759750042328389977_MK
    real(MK), parameter :: twopi_inv     = 0.159154943091895335768883763372514362034459645740456448747667_MK
    real(MK), parameter :: fourpi_inv    = 0.079577471545947667884441881686257181017229822870228224373833_MK
    real(MK), parameter :: four_third_pi = 4.188790204786390984616857844372670512262892532500141094633259_MK
    real(MK), parameter :: rad2deg       = 57.29577951308232087679815481410517033240547246656432154916024_MK
    real(MK), parameter :: deg2rad       = 0.017453292519943295769236907684886127134428718885417254560971_MK
    ! NaN
    integer, parameter  :: NaN=-999999
    real(MK), parameter :: rNaN=-999999._MK
    real(SP), parameter :: NaN_SP=-999999._SP

    interface is_nan
        module procedure iis_nan, ris_nan
    end interface
contains
    logical function iis_nan(x)
        integer,intent(in) ::x
        iis_nan=(x==-NaN)
    end function

    logical function ris_nan(x)
        use PrecisionMod, only:PRECISION_EPS
        real(MK),intent(in) ::x
        ris_nan=abs(x-rNaN)<PRECISION_EPS
    end function

end module MathConstants


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     1/976
!
!     a program for testing all vector laplacian and its inverse
!
!     (1) first set the vector function (rotation about equator) using
!         v = cos(phi) and w = -cos(theta)*sin(phi)
!
!     (2) set vector laplacian ananlytically
!         vlap = -2.*cos(phi)=-2.*v, wlap = -2.*w
!         (i.e., L(v, w) = -2.*(v, w) so (v, w) is an eigenfunction for the
!         vector Laplacian with eigenvalue -2.
!
!     (3) compute the coefficients br, bi, cr, ci of (v, w) using vector analysis
!
!     (3) compute the vector laplacian of (v, w) using vlapec, vlapes, vlapgc, vlapgs
!
!     (4) compare (3) with (2)
!
!     (5) invert (4) and compare with (v, w)
!
program tvlap

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: err2v
    real(wp) :: err2w
    integer(ip) :: i
    integer(ip) :: solver_case

    integer(ip) :: error_flag
    integer(ip) :: j
    integer(ip) :: k

    real(wp) :: phi

    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta

    ! Set dimensions with parameter statements
    integer(ip), parameter :: nlat = 29, nlon = 16, nt = 1
    integer(ip), parameter :: mdbc = min(nlat, nlon/2)
    integer(ip), parameter :: isym = 0, ityp = 0
    real(wp), allocatable  :: wavetable(:)
    real(wp), dimension(mdbc, nlat, nt) :: br, bi, cr, ci
    real(wp), dimension(nlat)           :: gaussian_latitudes, gaussian_weights
    real(wp), dimension(nlat, nlon, nt) :: v, w, ve, we, vlap, wlap, vlape, wlape
    real(wp), parameter                 :: ZERO = 0.0_wp, TWO = 2.0_wp

    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")

    ! Set equally spaced colatitude and longitude increments
    dphi = TWO_PI/nlon
    dlat = PI/(nlat-1)

    call compute_gaussian_latitudes_and_weights(nlat, &
        gaussian_latitudes, gaussian_weights, error_flag)

    call name("compute_gaussian_latitudes_and_weights")
    call iout(error_flag, " error_flag")
    call vecout(gaussian_latitudes, "gaussian_latitudes", nlat)
    !
    !     test all divergence and inverse divergence subroutines
    !
    do solver_case=1, 4
        call name("****")
        call name("****")
        call iout(solver_case, "icas")

        ! Set vector field v, w
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (solver_case)
                        case (0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    if (k==1) then
                        v(i, j, k) = cosp
                        w(i, j, k) = -cost*sinp
                        vlape(i, j, k) = -TWO * v(i, j, k)
                        wlape(i, j, k) = -TWO * w(i, j, k)
                    end if
                end do
            end do
        end do

        ! Store exact solution
        ve = v
        we = w

        select case (solver_case)
            case (1)

                call name("**ec")
                !
                !     analyze vector field
                !
                call initialize_vhaec(nlat, nlon, wavetable, error_flag)
                call name("vhai")
                call iout(error_flag, "error_flag = ")

                call vhaec(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vha ")
                call iout(error_flag, "error_flag = ")

                !     compute vector laplacian
                call initialize_vhsec(nlat, nlon, wavetable, error_flag)
                call name("vhsi")
                call iout(error_flag, "error_flag = ")

                call vlapec(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlap")
                call iout(error_flag, "error_flag = ")

            case (2)

                call name("**es")
                !
                !     analyze vector field
                !
                call initialize_vhaes(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhaes")
                call iout(error_flag, "error_flag = ")

                call vhaes(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vhaes")
                call iout(error_flag, "error_flag = ")

                call initialize_vhses(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhses")
                call iout(error_flag, "error_flag = ")

                call vlapes(nlat, nlon, isym, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlapes")
                call iout(error_flag, "error_flag = ")

            case (3)

                call name("**gc")
                !
                !     analyze vector field
                !
                call initialize_vhagc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhagc")
                call iout(error_flag, "error_flag = ")

                call vhagc(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vhagc")
                call iout(error_flag, "error_flag = ")

                !     compute vector laplacian
                !

                call initialize_vhsgc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgc")
                call iout(error_flag, "error_flag = ")

                call vlapgc(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlapgc")
                call iout(error_flag, "error_flag = ")

            case (4)

                call name("**gs")
                !
                !     analyze vector field
                !
                call initialize_vhags(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhags")
                call iout(error_flag, "error_flag = ")

                call vhags(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vhags")
                call iout(error_flag, "error_flag = ")

                !     compute vector laplacian
                call initialize_vhsgs(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgs")
                call iout(error_flag, "error_flag = ")

                call vlapgs(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlapgs")
                call iout(error_flag, "error_flag = ")

        end select

        ! Set and print least squares discretization error in vlap, wlap
        err2v = norm2(vlape - vlap)
        err2w = norm2(wlape - wlap)
        call vout(err2v, "errv")
        call vout(err2w, "errw")

        ! Now recompute (v, w) inverting (vlap, wlap) ivlap codes
        v = ZERO
        w = ZERO

        select case (solver_case)
            case (1)
                call name("analyze vector field (vlap, wlap)")
                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhaec(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhaec")
                call iout(error_flag, "error_flag = ")

                call vhaec(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhaec ")
                call iout(error_flag, "error_flag = ")

                call initialize_vhsec(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsec")
                call iout(error_flag, "error_flag = ")

                call ivlapec(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapec")
                call iout(error_flag, "error_flag = ")

            case (2)

                call name("analyze vector field (vlap, wlap)")
                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhaes(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhaes")
                call iout(error_flag, "error_flag = ")

                call vhaes(nlat, nlon, isym, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhaes")
                call iout(error_flag, "error_flag = ")

                call initialize_vhses(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhses")
                call iout(error_flag, "error_flag = ")

                call ivlapes(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapes")
                call iout(error_flag, "error_flag = ")

            case (3)

                call name("analyze vector field (vlap, wlap)")

                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhagc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhagc")
                call iout(error_flag, "error_flag = ")

                call vhagc(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhagc")
                call iout(error_flag, "error_flag = ")

                call initialize_vhsgc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgc")
                call iout(error_flag, "error_flag = ")

                call ivlapgc(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapgc")
                call iout(error_flag, "error_flag = ")

            case default

                call name("analyze vector field (vlap, wlap)")

                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhags(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhags")
                call iout(error_flag, "error_flag = ")

                call vhags(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhags")
                call iout(error_flag, "error_flag = ")

                call initialize_vhsgs(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgs")
                call iout(error_flag, "error_flag = ")

                call ivlapgs(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapgs")
                call iout(error_flag, "error_flag = ")

        end select

        ! Compare this v, w with original
        err2v = norm2(ve - v)
        err2w = norm2(we - w)
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    end do

    ! Release memory
    deallocate (wavetable)

end program tvlap


       function det_2(T)
        implicit none

        type(Tensor2) :: T
        real(kind=8) :: det_2

        det_2 = T%ab(1,1)*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2))
     *        + T%ab(1,2)*(T%ab(2,3)*T%ab(3,1)-T%ab(2,1)*T%ab(3,3))
     *        + T%ab(1,3)*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1))

       end function det_2

       function det_2s(T)
        ! strain
        implicit none

        type(Tensor2s), intent(in) :: T
        !integer, intent(in), optional :: w
        real(kind=8) :: det_2s!, v

        !v = 1.0

        det_2s = T%a6(1)*T%a6(2)*T%a6(3)
     *         + T%a6(4)*T%a6(5)*T%a6(6)! /v**3
     *         + T%a6(6)*T%a6(4)*T%a6(5)! /v**3
     *         - T%a6(6)*T%a6(2)*T%a6(6)! /v**3
     *         - T%a6(5)*T%a6(5)*T%a6(1)! /v**3
     *         - T%a6(3)*T%a6(4)*T%a6(4)! /v**3

       end function det_2s


MODULE ProblemBank
IMPLICIT NONE

CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!	This is the where MOPs are defined
SUBROUTINE MOP1_circles(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	fit(1) = indv(1)**2 + indv(2)**2
	fit(2) = (indv(1)-2.0)**2 + (indv(2)-2.0)**2
	viol = 0
END SUBROUTINE MOP1_circles

SUBROUTINE MOP2_Fonseca(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	fit(1) = 1-EXP(-((indv(1)- 1.0/(3.0)**0.5)**2.0 + &
					(indv(2) - 1.0/(3.0)**0.5)**2.0 + &
					(indv(3) - 1.0/(3.0)**0.5)**2.0));
	fit(2) = 1-EXP(-((indv(1)+ 1.0/(3.0)**0.5)**2.0 + &
					(indv(2) + 1.0/(3.0)**0.5)**2.0 + &
					(indv(3) + 1.0/(3.0)**0.5)**2.0));
	viol = 0
END SUBROUTINE MOP2_Fonseca

SUBROUTINE MOP3_Poloni(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: 	A1 = 0.873648562314064, &	!= 0.5*sin(1)-2*cos(1)+sin(2)-1.5*cos(2)
			A2 = 2.748572443268639, &	!=1.5*sin(1)-cos(1)+2*sin(2)-.5*cos(2)
			x, y ,B1, B2

	x = indv(1)
	y = indv(2)
	B1 = 0.5*SIN(x) - 2.0*COS(x) + SIN(y) - 1.5*COS(y)
	B2 = 1.5*SIN(x) - COS(x) + 2.0*SIN(y) - 0.5*COS(y)

	fit(1) = (1 + (A1-B1)**2 + (A2-B2)**2)
	fit(2) = ((x+3)**2 + (y+1)**2)

	viol = 0
END SUBROUTINE MOP3_Poloni

SUBROUTINE MOP4_Kursawe(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL::a, b, x1, x2, x3

	a = 0.8
	b = 3.0
	x1 = indv(1)
	x2 = indv(2)
	x3 = indv(3)

	fit(1) = -10 * (exp(-0.2 * SQRT(x1**2.0 + x2**2.0)) &
    			  + exp(-0.2 * SQRT(x2**2.0 + x3**2.0)))
	fit(2) =(ABS(x1))**a + 5.0*SIN(x1**b) + &
    		(ABS(x2))**a + 5.0*SIN(x2**b) + &
    		(ABS(x3))**a + 5.0*SIN(x3**b)

	viol = 0
END SUBROUTINE MOP4_Kursawe

SUBROUTINE MOP5_Viennet(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: x, y, temp

	y = indv(2)
	x = indv(1)
	temp = x**2+y**2

	fit(1) = 0.5 * temp + SIN(temp)
	fit(2) = (3.0*x-2.0*y+4.0)**2.0/8.0 + &
			 (x-y+1.0)**2.0/27.0 + 15.0
	fit(3) = 1.0 / (temp+1.0) - 1.1*EXP(-temp)

	viol = 0
END SUBROUTINE MOP5_Viennet

SUBROUTINE ZDT3_10D(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: r
	INTEGER::dims = 10, i
	REAL, PARAMETER:: pi = 3.141592653589793

	fit(1) = indv(1)

	r = 0.0

	DO i = 2, dims
		r = r + indv(i)
	END DO

	fit(2) = (1.0+9.0*r/(dims-1)) * &
			(1-SQRT(indv(1)/(1.0+9.0*r/(dims-1))) - &
			(indv(1)/(1.0+9.0*r/(dims-1)))*SIN(10.0*pi*indv(1)));

	viol = 0
END SUBROUTINE ZDT3_10D

SUBROUTINE MOP_C4_Tanaka(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: a, b

	a = 0.1
	b = 16.0

	fit(1) = indv(1)
	fit(2) = indv(2)

	viol = 0
	IF (- indv(1)**2.0 - indv(2)**2.0 + 1.0 + &
		a * COS(b*ATAN(indv(1)/indv(2)))>0.0) viol = 1
END SUBROUTINE 	MOP_C4_Tanaka

END MODULE ProblemBank


      PROGRAM xqrdcmp
C     driver for routine qrdcmp
      INTEGER NP
      PARAMETER(NP=20)
      INTEGER i,j,k,l,m,n
      REAL con,a(NP,NP),c(NP),d(NP),q(NP,NP),qt(NP,NP),r(NP,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,*) ((x(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     perform the decomposition
      call qrdcmp(a,n,NP,c,d,sing)
      if (sing) write(*,*) 'Singularity in QR decomposition.'
C     find the Q and R matrices
      do 13 k=1,n
        do 12 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
12      continue
13    continue
      do 21 i=n-1,1,-1
        con=0.0
        do 14 k=i,n
          con=con+a(k,i)**2
14      continue
        con=con/2.0
        do 17 k=i,n
          do 16 l=i,n
            qt(k,l)=0.0
            do 15 j=i,n
              qt(k,l)=qt(k,l)+q(j,l)*a(k,i)*a(j,i)/con
15          continue
16        continue
17      continue
        do 19 k=i,n
          do 18 l=i,n
            q(k,l)=q(k,l)-qt(k,l)
18        continue
19      continue
21    continue
C     compute product of Q and R matrices for comparison with original matrix.
      do 24 k=1,n
        do 23 l=1,n
          x(k,l)=0.0
          do 22 j=1,n
            x(k,l)=x(k,l)+q(k,j)*r(j,l)
22        continue
23      continue
24    continue
      write(*,*) 'Product of Q and R matrices:'
      do 25 k=1,n
        write(*,'(1x,6f12.6)') (x(k,l), l=1,n)
25    continue
      write(*,*) 'Q matrix of the decomposition:'
      do 26 k=1,n
        write(*,'(1x,6f12.6)') (q(k,l), l=1,n)
26    continue
      write(*,*) 'R matrix of the decomposition:'
      do 27 k=1,n
        write(*,'(1x,6f12.6)') (r(k,l), l=1,n)
27    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/xqrdcmp.for


integer function PlmIndex(l,m)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will return the index corresponding
!	to a given l and m in the arrays of Legendre Polynomials
!	generated by routines such as PlmBar and PlmSchmidt.
!
!	Calling Parameters:
!		l	Spherical harmonic angular degree.
!		m	Spherical harmonic angular order.
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek (May 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in)	:: l, m

	if (l < 0) then
		print*, "Error --- PlmIndex"
		print*, "L must be greater of equal to 0."
		print*, "L = ", l
		print*, "M = ", m
		stop
	elseif (m < 0 .or.  m > l) then
		print*, "Error --- PlmIndex"
		print*, "M must be greater than or equal to zero and less than or equal to L."
		print*, "L = ", l
		print*, "M = ", m
		stop
	endif

	PlmIndex = l*(l+1)/2+m+1

end function PlmIndex


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Exponentiation (** operator) to real, double, or complex powers.

	program p
	implicit complex (c), real*8 (d)

	integer rslts(18), expect(18)

	integer ctoi
	ctoi(c) = real(c) + aimag(c)

	data x2 / 2.0/, d2 / 2.0d0/, i2 / 2 /
	data c2, c23, c11, c12/ (2, 0), (2, 3), (1, 1), (1, 2) /

c --- tests 1 - 6:  exponentiation to real power:

	rslts(1) = 2.1 ** 2.0
	rslts(2) = 2.1 ** x2
	rslts(3) = (3 ** x2) * 100.001
	rslts(4) = (i2 + 1) ** 3.01
	rslts(5) = i2 ** (x2 + 1) + .01
	rslts(6) = x2 ** 0.0 * 100

c --- tests 7 - 12: exponentiation to double prec. power:

	rslts(7) = 2.1d0 ** 2.0d0
	rslts(8) = 2.1d0 ** x2
	rslts(9) = (3 ** d2) * 100.001
	rslts(10) = (x2 + 1) ** 3.01d0
	rslts(11) = i2 ** (d2 + 1) + .01
	rslts(12) = d2 ** 0.0 * 100

c --- tests 13 - 18:  exponentiation to complex power:

	rslts(13) = ctoi( (2.1, 0.0) ** (2.0, 0.0) )
	rslts(14) = ctoi( (2.1, 0.0) ** c2)
	rslts(15) = ctoi( c23 ** x2 + .001 )
	rslts(16) = c23 ** c11 + 10
	rslts(17) = ctoi( 10 ** c12 )
	rslts(18) = ctoi(x2 ** (-1.0, 2.0) * 10)

c --- check results:

	call check(rslts, expect, 18)

	data expect / 4, 4, 900, 27, 8, 100,
     +                4, 4, 900, 27, 8, 100,
     +                4, 4, 7, 9, -11, 5      /

	end


subroutine sphbes(n,x,sj,sjp)
  !   Calculates the spherical bessel function $j_l(x)$ and its first derivative $j'_l(x)$
  !   at the point $x\le 0$, for l=0,1,...n
  implicit none
  integer, intent(in) :: n    ! Maximum l to be calculated
  real(8), intent(in) :: x    ! The argument at which the bessel functions are calculated
  real(8), intent(out) :: sj(*) ! values of spherical bessel function
  real(8), intent(out) :: sjp(*)! values of first derivative of the spherical bessel function
  !
  integer(4) :: l
  real(8) :: factor  ! Multiplying factor between the spherical bessel func and the regular bessel func of half integer order
  real(8) :: rj(n+1) ! Array containing the regular bessel function of order i-1/2
  real(8) :: rjp(n+1)! Array containing the first derivative of the regular bessel function of order i-1/2
  real(8), parameter :: rtpio2 = 1.25331413731550025120788d+0
  external bessj
  intrinsic sqrt

  if(n.lt.0.or.x.lt.0.)then
     write(6,*) "ERROR in sphbes:bad arguments"
     write(6,*)'  input: x = ',x
     write(6,*)'  input: n = ',n
     stop 'bad arguments in sphbes'
  endif

  if(x.gt.0.0d0)then
     call bessj(x,n,rj,rjp)

     factor=rtpio2/sqrt(x)
     do l=1,n+1
        sj(l)=factor*rj(l)
        sjp(l)=factor*rjp(l)-sj(l)/(2.0d0*x)
     enddo
  else
     do l=1,n+1
        sj(l)=0.0d0
        sjp(l)=0.0d0
     enddo
     sj(1)=1.0d0
     sjp(2)=1.0d0/3.0d0
  endif
end subroutine sphbes

subroutine bessj(x,nl,rj,rjp)
  !Returns the regular Bessel functions of first kind
  !$\texttt{rj(l)}=J_{l-\frac{1}{2}}$ and their derivatives
  !$\texttt{rjp(l)}=J'_{l-\frac{1}{2}}$, for positive \texttt{x} and for
  !$1\le l \le nl+1$, using Steed's method.
  implicit none
  real(8), intent(in) :: x
  integer, intent(in) :: nl
  real(8), intent(out) :: rj(*)
  real(8), intent(out) :: rjp(*)
  !
  integer :: i, isign, l
  real(8) :: xnu, b, c, d, del, f, fact, gam, h, p, q, rjl, rjl1, rjmu, rjp1, rjpl, rjtemp, w, xi, xi2, xmu, xmu2
  integer, parameter :: maxit=10000
  real(8), parameter :: eps=1.e-16
  real(8), parameter :: fpmin=1.e-30
  real(8), parameter :: pi=3.141592653589793d+0
  ! Original subroutine: bessjy.for (c) copr. 1986-92 numerical recipes software &124i..
  if(x.le.0..or.nl.lt.0) stop 'bad arguments in bessj'
  xnu=dble(nl)+0.5d0
  xmu=0.5d0
  xmu2=xmu*xmu
  xi=1.d0/x
  xi2=2.d0*xi
  !     The Wronskian
  w=xi2/pi
  !     Evaluate the continued fraction expansion for J'_(nl-1/2)/J_(nl-1/2)
  !     by the modified Lentz's method. isign keeps track of sign changes in
  !     the denominator
  isign=1
  h=xnu*xi
  if(h.lt.fpmin)h=fpmin
  b=xi2*xnu
  d=0.d0
  c=h
  do i=1,maxit
     b=b+xi2
     d=b-d
     if(abs(d).lt.fpmin) d=fpmin
     c=b-1.d0/c
     if(abs(c).lt.fpmin) c=fpmin
     d=1.d0/d
     del=c*d
     h=del*h
     if(d.lt.0.d0) isign=-isign
     if(abs(del-1.d0).lt.eps) goto 1
  enddo
!11   continue
  stop 'x too large in bessjy; try asymptotic expansion'
1 continue
  !     Initialize J and J' for downward recurrence
  rjl=isign*fpmin
  rjpl=h*rjl
  !     Store values for later rescaling
  rjl1=rjl
  rjp1=rjpl
  !     Downward recurrence (unnormalized)
  fact=xnu*xi
  do l=nl,0,-1
     rjtemp=fact*rjl+rjpl
     fact=fact-xi
     rjpl=fact*rjtemp-rjl
     rjl=rjtemp
  enddo
  if(rjl.eq.0.d0)rjl=eps
  f=rjpl/rjl
  !     Equation 6.7.3 Numerical Recipies in Fortran
  p=-.5d0*xi
  q=1.d0
  !     Equation 6.7.6 Numerical Recipies in Fortran
  gam=(p-f)/q
  !     Equation 6.7.7 Numerical Recipies in Fortran
  rjmu=sqrt(w/((p-f)*gam+q))
  rjmu=sign(rjmu,rjl)
  !     Scale original J and J'
  fact=rjmu/rjl
  rj(nl+1)=rjl1*fact
  rjp(nl+1)=rjp1*fact
  fact=xnu*xi
  !     Downward recurence
  do l=nl,1,-1
     rj(l)=fact*rj(l+1)+rjp(l+1)
     fact=fact-xi
     rjp(l)=fact*rj(l)-rj(l+1)
  enddo ! l
end subroutine bessj

subroutine ylm(y,v,lmax)
  !  This subroutine calculates spherical harmonics up to l=lmax for a
  ! given vector in cartesian coordinates
  !
  !  The spherical harmonics (Condon and Shortley convention)
  !  $Y_{0,0},Y_{1,-1},Y_{1,0},Y_{1,1},Y_{2,-2} ...Y_{LMAX,LMAX}$
  !           for vector V (given in Cartesian coordinates)
  !           are calculated. In the Condon Shortley convention the
  !           spherical harmonics are defined as
  !
  !\begin{equation}
  ! Y_{l,m}=(-1)^m \sqrt{\frac{1}{2\pi}} P_l^m(cos(\theta))e^{im\phi}
  !\end{equation}
  !
  !\noindent
  !where $P_l^m(cos(\theta))$ is the normalized Associated Legendre
  !           function. Thus,
  !\begin{equation}
  ! Y_{l,-m}=(-1)^m Y^*_{l,m}
  !\end{equation}
  !
  !The output is writen to the vector Y(:) such that
  ! Y(k)$=Y_{l,m}$ with $k=l^2+l+m+1$, thus,
  ! Y(1)$=Y_{0,0}$, Y(2)$=Y_{1,-1}$, Y(3)$=Y_{1,0}$, Y(4)$=Y_{1,1}$...
  !Y(lmax*lmax+1)$=Y_{lmax,-lmax}... $Y((lmax+1)*(lmax+1))$=Y_{lmax,lmax}$
  !
  !   The basic algorithm used to calculate the spherical
  !   harmonics for vector V is as follows:
  !
  !\begin{subequations}
  !\begin{align}
  ! Y_{0,0}=&\sqrt{\frac{1}{4\pi}}\\
  ! Y_{1,0}=&\sqrt{\frac{3}{4\pi}}cos(\theta)\\
  ! Y_{1,1}=&-\sqrt{\frac{3}{8\pi}}sin(\theta)e^{i\phi}\\
  ! Y_{1,-1}=&-Y_{1,1}\\
  ! Y_{l,l}=&-\sqrt{\frac{2l+1}{2l}}sin(\theta)e^{i\phi}Y_{l-1,l-1}\\
  ! Y_{l,m}=&\sqrt{\frac{(2l-1)(2l+1)}{(l-m)(l+m)}}%
  !cos(\theta)Y_{l-1,m}-\sqrt{\frac{(l-1+m)(l-1-m)(2l+1)}{(2l-3)(l-m)(l+m)}}%
  !Y_{l-2,m}
  !\end{align}
  !\end{subequations}
  !
  implicit none
  integer,intent(in):: lmax  ! maximum l for which the spherical  harmonics are calculated
  real(8),intent(in) :: v(3) ! vector (cartesian coordinates) for which  the spherical harmonics are calculated
  complex*16,intent(out) :: y((lmax+1)*(lmax+1)) ! the values of the spherical harmonics dimension (lmax+1)^2
  !
  integer ::  i2l, i4l2, index, index2, l, m, msign
  real(8) ::  a, b, c, ab, abc, abmax, abcmax
  real(8) ::  d4ll1c, d2l13, pi
  real(8) ::  costh, sinth, cosph, sinph
  real(8) ::  temp1, temp2, temp3
  real(8) ::  yllr, yll1r, yl1l1r, ylmr
  real(8) ::  ylli, yll1i, yl1l1i, ylmi
  pi = (4.0d+0)*atan(1.0d+0)
  !        y(0,0)
  yllr = 1.0d+0/sqrt(4.0d+0*pi)
  ylli = 0.0d+0
  y(1) = cmplx(yllr,ylli,8)
  !        continue only if spherical harmonics for (l .gt. 0) are desired
  if (lmax .le. 0) return
  !        calculate sin(phi), cos(phi), sin(theta), cos(theta)
  !        theta, phi ... polar angles of vector v
  abmax  = max(abs(v(1)),abs(v(2)))
  if (abmax .gt. 0.0d+0) then
     a = v(1)/abmax
     b = v(2)/abmax
     ab = sqrt(a*a+b*b)
     cosph = a/ab
     sinph = b/ab
  else
     cosph = 1.0d+0
     sinph = 0.0d+0
  endif
  abcmax = max(abmax,abs(v(3)))
  if (abcmax .gt. 0.0d+0) then
     a = v(1)/abcmax
     b = v(2)/abcmax
     c = v(3)/abcmax
     ab = a*a + b*b
     abc = sqrt(ab + c*c)
     costh = c/abc
     sinth = sqrt(ab)/abc
  else
     costh = 1.0d+0
     sinth = 0.0d+0
  endif
  !        y(1,0)
  y(3) = cmplx(sqrt(3.0d+0)*yllr*costh,0.0d+0,8)
  !        y(1,1) ( = -conjg(y(1,-1)))
  temp1 = -sqrt(1.5d+0)*yllr*sinth
  y(4) = cmplx(temp1*cosph,temp1*sinph,8)
  y(2) = -conjg(y(4))
  !
  do l = 2, lmax
     index  = l*l+1
     index2 = index + 2*l
     msign  = 1 - 2*mod(l,2)
     !        yll = y(l,l) = f(y(l-1,l-1)) ... formula 1
     yl1l1r = dble(y(index-1))
     yl1l1i = aimag(y(index-1))
     temp1 = -sqrt(dble(2*l+1)/dble(2*l))*sinth
     yllr = temp1*(cosph*yl1l1r - sinph*yl1l1i)
     ylli = temp1*(cosph*yl1l1i + sinph*yl1l1r)
     y(index2) = cmplx(yllr,ylli,8)
     y(index)  = msign*conjg(y(index2))
     index2 = index2 - 1
     index  = index  + 1
     !        yll1 = y(l,l-1) = f(y(l-1,l-1)) ... formula 2
     !               (the coefficient for y(l-2,l-1) in formula 2 is zero)
     temp2 = sqrt(dble(2*l+1))*costh
     yll1r = temp2*yl1l1r
     yll1i = temp2*yl1l1i
     y(index2) = cmplx(yll1r,yll1i,8)
     y(index)  = -msign*conjg(y(index2))
     index2 = index2 - 1
     index  = index  + 1
     !
     i4l2 = index2 - 4*l + 2
     i2l  = index2 - 2*l
     d4ll1c = costh*sqrt(dble(4*l*l-1))
     d2l13  = -sqrt(dble(2*l+1)/dble(2*l-3))
     do m = l - 2, 0, -1
        !        ylm = y(l,m) = f(y(l-2,m),y(l-1,m)) ... formula 2
        temp1 = 1.0d+0/sqrt(dble((l+m)*(l-m)))
        temp2 = d4ll1c*temp1
        temp3 = d2l13*sqrt(dble((l+m-1)*(l-m-1)))*temp1
        ylmr = temp2*dble(y(i2l))  + temp3*dble(y(i4l2))
        ylmi = temp2*aimag(y(i2l)) + temp3*aimag(y(i4l2))
        y(index2) = cmplx(ylmr,ylmi,8)
        y(index)  = msign*conjg(y(index2))
        !
        msign  = -msign
        index2 = index2 - 1
        index  = index  + 1
        i4l2   = i4l2   - 1
        i2l    = i2l    - 1
     enddo  ! m
  enddo ! l
end subroutine ylm


ELEMENTAL FUNCTION func_radians(x) RESULT(ans)
    ! This function returns the passed angle converted from degrees to radians.

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare input variables ...
    REAL(kind = REAL64), INTENT(in)                                             :: x        ! The input angle in degrees.

    ! Declare output variables ...
    REAL(kind = REAL64)                                                         :: ans      ! The output angle in radians.

    ! Set value ...
    ans = const_pi * x / 180.0e0_REAL64                                         ! [rad]
END FUNCTION func_radians


      PROGRAM TEST
      USE FMZM

!   FM_FIND_MIN is a multiple precision function minimization routine that uses Brent's method.

!   The function to be minimized or maximized is  F(X,NF).
!   X  is the argument to the function.
!   NF is the function number in case extrema to several functions are needed.

      IMPLICIT NONE
      CHARACTER(80)  :: ST1,ST2

!  declare the multiple precision variables.

      TYPE (FM), SAVE     :: A, B, TOL, XVAL, FVAL
      TYPE (FM), EXTERNAL :: F

!             Set the FM precision to 50 significant digits (plus a few more "guard digits")

      CALL FM_SET(50)

!             Find a minimum of the first function,  X**3 - 9*X + 17.
!             A, B are two endpoints of an interval in which the search takes place.

      A = 1
      B = 2

!             TOL is the error tolerance.  For most functions, the best accuracy we can obtain
!                 corresponds to about half the digits being used for the arithmetic.
!                 EPSILON(A) gives the relative accuracy of full precision, so SQRT(EPSILON(A))
!                 gives the relative accuracy of half precision.

      TOL = SQRT(EPSILON(A))

!             For this call no trace output will be done (KPRT = 0).
!             KW = 6 is used, so any error messages will go to the screen.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 1.  Call FM_FIND_MIN to find a relative minimum between 1 and 2'
      WRITE (*,*) '          for f(x) = X**3 - 9*X + 17.'
      WRITE (*,*) '          Use KPRT = 0, so no output will be done in the routine, then'
      WRITE (*,*) '          write the results from the main program.'

      CALL FM_FIND_MIN(1,A,B,TOL,XVAL,FVAL,F,1,0,6)

!             Write the result, using F32.30 format.

      CALL FM_FORM('F32.30',XVAL,ST1)
      CALL FM_FORM('F32.30',FVAL,ST2)
      WRITE (*,"(/'  A minimum for function 1 is'/'     x  = ',A/'   f(x) = ',A)")  &
               TRIM(ST1),TRIM(ST2)

!             Find a maximum of the first function,  X**3 - 9*X + 17.

!             This time we use FM_FIND_MIN's built-in trace (KPRT = 1) to print the final
!             approximation to the root.  The output will appear on more than one line, to
!             allow for the possibility that precision could be hundreds or thousands of digits,
!             so the number might not fit on one line.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 2.  Find a relative maximum between -5 and 1.'
      WRITE (*,*) '          Use KPRT = 1, so FM_FIND_MIN will print the results.'

      CALL FM_FIND_MIN(2,-TO_FM('5.0D0'),TO_FM('1.0D0'),TOL,XVAL,FVAL,F,1,1,6)

!             Find a maximum of the first function,  X**3 - 9*X + 17.

!             See what happens when the maximum value is at an endpoint of the search interval.
!             The algorithm still finds a relative maximum in the interior of the interval,
!             not the absolute maximum at x=5.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 3.  Find a relative maximum between -5 and 5.'
      WRITE (*,*) '          Use KPRT = 2, so FM_FIND_MIN will print all iterations,'
      WRITE (*,*) '          as well as the final results.'

      CALL FM_FIND_MIN(2,-TO_FM('5.0D0'),TO_FM('5.0D0'),TOL,XVAL,FVAL,F,1,2,6)

!             Find a minimum of the second function,  gamma(x).

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 4.  The gamma function has one minimum for positive x.'
      WRITE (*,*) '          Find it, printing all iterations.'
      WRITE (*,*) '          Fortran did not provide gamma(x) before the Fortran 2008 standard, '
      WRITE (*,*) '          so this case was not included in the original fmin.f95.'

      CALL FM_FIND_MIN(1,TO_FM('0.1D0'),TO_FM('3.0D0'),TOL,XVAL,FVAL,F,2,2,6)

      WRITE (*,*) ' '

      END PROGRAM TEST

      FUNCTION F(X,NF)     RESULT (RETURN_VALUE)
      USE FMZM

!   X  is the argument to the function.
!   NF is the function number.

      IMPLICIT NONE
      INTEGER :: NF
      TYPE (FM) :: RETURN_VALUE,X

      IF      (NF == 1) THEN
          RETURN_VALUE = X**3 - 9*X + 17
      ELSE IF (NF == 2) THEN
          RETURN_VALUE = GAMMA(X)
      ELSE
          RETURN_VALUE = 3*X**2 + X - 2
      ENDIF

      END FUNCTION F


*       Home work #2
*       Question (1)
*       Write a Fortran program to calculate and find
*       error% between exact derivatives and numerical
*       derivatives of the following function using
*       all methods (forward , backward , 3-point method,
*       5-point method)

*       (ii)f(x)=x^6-cos(x)  at x=2

        write(*,*)'f(x)=X^6-cos(x)'
        write(*,*)'exact (df(x)/dx)= 6*X^5+sin(x)'
        write(*,*)'Enter the value of X ,to calculate df(x)/dx'
        Read(*,*)X
10      write(*,*)'Enter the value of H'
        Read(*,*)h
        If(H.LE.0)stop
        exact= 6*x**5+sin(x)
        fx=x**6-cos(x)
        fx1h_forward=(x+h)**6-cos(x+h)
        fx2h_forward=(x+2*h)**6-cos(x+2*h)
        fx1h_backward=(x-h)**6-cos(x-h)
        fx2h_backward=(x-2*h)**6-cos(x-2*h)

*       Forward Difference Deivative
        fbrime_forward=(fx1h_forward-fx)/h

*       Backward Difference Deivative
        fbrime_backward=(fx-fx1h_backward)/h

*       3-point Difference Deivative
        fbrime_3_point=(fx1h_forward-fx1h_backward)/(2*h)

*       5-point Difference Deivative
        fbrime_5_point_1= fx2h_backward -8*fx1h_backward
        fbrime_5_point_2=8*fx1h_forward-fx2h_forward
        fbrime_5_point=(fbrime_5_point_1 + fbrime_5_point_2)/(12*h)

        Error_forward=abs(exact-fbrime_forward)
        Error_backward=abs(exact-fbrime_backward)
        Error_3_point=abs(exact-fbrime_3_point)
        Error_5_point=abs(exact-fbrime_5_point)
20      format(4f 12.6)
        write(*,*)'   H           Error       fbrime      exact'
        write(*,20)H,Error_forward,fbrime_forward,exact
        write(*,20)H,Error_backward,fbrime_backward,exact
        write(*,20)H,Error_3_point,fbrime_3_point,exact
        write(*,20)H,Error_5_point,fbrime_5_point,exact
        Go to 10
*        Stop
        End


!============================================================================
! peuc.f90                                             Purser, October 2005
! Package for handy vector and matrix operations in Euclidean geometry.
! This package is primarily intended for 3D operations and three of the
! functions (Cross_product, Triple_product and Axial) do not possess simple
! generalizations to a generic number N of dimensions. The others, while
! admitting such N-dimensional generalizations, have not all been provided
! with such generic forms here at the time of writing, though some of these
! may be added at a future date.
!
!   FUNCTION:
! Normalized:     Normalized version of given vector
! Cross_product:  Vector cross-product of the given 2 vectors
! Outer_product:  outer-product matrix of the given 2 vectors
! Triple_product: Scalar triple product of given 3 vectors
! Det:            Determinant of given matrix
! Axial:          Convert axial-vector <--> 2-form (antisymmetric matrix)
! Diag:           Diagnl of given matrix, or diagonal matrix of given elements
! Trace:          Trace of given matrix
! Identity:       Identity 3*3 matrix, or identity n*n matrix for a given n
! Sarea:          Spherical area subtended by three vectors
! Huarea:         Spherical area subtended by right-angled spheical triangle
!   SUBROUTINE:
! Gram:           Right-handed orthogonal basis and rank, nrank. The first
!                 nrank basis vectors span the column range of matrix given,
!                 OR  ("plain" version) simple unpivoted gram-schmidt of a
!                 square matrix.
!============================================================================
module peuc
!============================================================================
use kinds
implicit none
private
public:: normalized,cross_product,outer_product,triple_product,det,axial, &
         diag,trace,identity,sarea,huarea,gram

interface normalized
   module procedure normalized_s,normalized_d
end interface
interface cross_product
   module procedure cross_product_s,cross_product_d
end interface
interface outer_product
   module procedure outer_product_s,outer_product_d
end interface
interface triple_product
   module procedure triple_product_s,triple_product_d
end interface
interface det
   module procedure det_s,det_d
end interface
interface axial
   module procedure axial3_s,axial3_d,axial33_s,axial33_d
end interface
interface diag
   module procedure diagn_s,diagn_d,diagnn_s,diagnn_d
end interface
interface trace
   module procedure trace_s,trace_d
end interface
interface identity
   module procedure identity_i,identity3_i
end interface
interface huarea
   module procedure huarea_s,huarea_d
end interface
interface sarea
   module procedure sarea_s,sarea_d
end interface
interface gram
   module procedure gram_s,gram_d,plaingram_s,plaingram_d
end interface

contains

!=============================================================================
function normalized_s(a)result(b)
!=============================================================================
real(sp),dimension(:),intent(IN):: a
real(sp),dimension(size(a))     :: b
real(sp)                        :: s
s=sqrt(dot_product(a,a)); if(s==0)then; b=0;else;b=a/s;endif
end function normalized_s
!=============================================================================
function normalized_d(a)result(b)
!=============================================================================
real(dp),dimension(:),intent(IN):: a
real(dp),dimension(size(a))     :: b
real(dp)                        :: s
s=sqrt(dot_product(a,a)); if(s==0)then; b=0;else;b=a/s;endif
end function normalized_d

!=============================================================================
function cross_product_s(a,b)
!=============================================================================
real(sp),dimension(3)           :: cross_product_s
real(sp),dimension(3),intent(in):: a,b
cross_product_s(1)=a(2)*b(3)-a(3)*b(2)
cross_product_s(2)=a(3)*b(1)-a(1)*b(3)
cross_product_s(3)=a(1)*b(2)-a(2)*b(1)
end function cross_product_s
!=============================================================================
function cross_product_d(a,b)result(cross_product)
!=============================================================================
real(dp),dimension(3)           :: cross_product
real(dp),dimension(3),intent(in):: a,b
cross_product(1)=a(2)*b(3)-a(3)*b(2)
cross_product(2)=a(3)*b(1)-a(1)*b(3)
cross_product(3)=a(1)*b(2)-a(2)*b(1)
end function cross_product_d

!=============================================================================
function outer_product_s(a,b)result(c)
!=============================================================================
real(sp),dimension(:),  intent(in ):: a
real(sp),dimension(:),  intent(in ):: b
real(sp),DIMENSION(size(a),size(b)):: c
integer                            :: nb,i
nb=size(b)
do i=1,nb; c(:,i)=a*b(i); enddo
end function outer_product_s
!=============================================================================
function outer_product_d(a,b)result(c)
!=============================================================================
real(dp),dimension(:),  intent(in ):: a
real(dp),dimension(:),  intent(in ):: b
real(dp),dimension(size(a),size(b)):: c
integer                            :: nb,i
nb=size(b)
do i=1,nb; c(:,i)=a*b(i); enddo
end function outer_product_d

!=============================================================================
function triple_product_s(a,b,c)result(tripleproduct)
!=============================================================================
real(sp),dimension(3),intent(IN ):: a,b,c
real(sp)                         :: tripleproduct
tripleproduct=dot_product( cross_product(a,b),c )
end function triple_product_s
!=============================================================================
function triple_product_d(a,b,c)result(tripleproduct)
!=============================================================================
real(dp),dimension(3),intent(IN ):: a,b,c
real(dp)                         :: tripleproduct
tripleproduct=dot_product( cross_product(a,b),c )
end function triple_product_d

!=============================================================================
function det_s(a)result(det)
!=============================================================================
real(sp),dimension(:,:),intent(IN )    ::a
real(sp)                               :: det
real(sp),dimension(size(a,1),size(a,1)):: b
integer                                :: n,nrank
n=size(a,1)
if(n==3)then
   det=triple_product(a(:,1),a(:,2),a(:,3))
else
   call gram(a,b,nrank,det)
   if(nrank<n)det=0
endif
end function det_s
!=============================================================================
function det_d(a)result(det)
!=============================================================================
real(dp),dimension(:,:),intent(IN )    ::a
real(dp)                               :: det
real(dp),dimension(size(a,1),size(a,1)):: b
integer                                :: n,nrank
n=size(a,1)
if(n==3)then
   det=triple_product(a(:,1),a(:,2),a(:,3))
else
   call gram(a,b,nrank,det)
   if(nrank<n)det=0
endif
end function det_d

!=============================================================================
function axial3_s(a)result(b)
!=============================================================================
real(sp),dimension(3),intent(IN ):: a
real(sp),dimension(3,3)          :: b
b=0;b(3,2)=a(1);b(1,3)=a(2);b(2,1)=a(3);b(2,3)=-a(1);b(3,1)=-a(2);b(1,2)=-a(3)
end function axial3_s
!=============================================================================
function axial3_d(a)result(b)
!=============================================================================
real(dp),dimension(3),intent(IN ):: a
real(dp),dimension(3,3)          :: b
b=0;b(3,2)=a(1);b(1,3)=a(2);b(2,1)=a(3);b(2,3)=-a(1);b(3,1)=-a(2);b(1,2)=-a(3)
end function axial3_d
!=============================================================================
function axial33_s(b)result(a)
!=============================================================================
real(sp),dimension(3,3),intent(IN ):: b
real(sp),dimension(3)              :: a
a(1)=(b(3,2)-b(2,3))/2; a(2)=(b(1,3)-b(3,1))/2; a(3)=(b(2,1)-b(1,2))/2
end function axial33_s
!=============================================================================
function axial33_d(b)result(a)
!=============================================================================
real(dp),dimension(3,3),intent(IN ):: b
real(dp),dimension(3)              :: a
a(1)=(b(3,2)-b(2,3))/2; a(2)=(b(1,3)-b(3,1))/2; a(3)=(b(2,1)-b(1,2))/2
end function axial33_d

!=============================================================================
function diagn_s(a)result(b)
!=============================================================================
real(sp),dimension(:),intent(IN )  :: a
real(sp),dimension(size(a),size(a)):: b
integer                            :: n,i
n=size(a)
b=0; do i=1,n; b(i,i)=a(i); enddo
end function diagn_s
!=============================================================================
function diagn_d(a)result(b)
!=============================================================================
real(dp),dimension(:),intent(IN )  :: a
real(dp),dimension(size(a),size(a)):: b
integer                            :: n,i
n=size(a)
b=0; do i=1,n; b(i,i)=a(i); enddo
end function diagn_d
!=============================================================================
function diagnn_s(b)result(a)
!=============================================================================
real(sp),dimension(:,:),intent(IN ):: b
real(sp),dimension(size(b,1))      :: a
integer                            :: n,i
n=size(b,1)
do i=1,n; a(i)=b(i,i); enddo
end function diagnn_s
!=============================================================================
function diagnn_d(b)result(a)
!=============================================================================
real(dp),dimension(:,:),intent(IN ):: b
real(dp),dimension(size(b,1))      :: a
integer                            :: n,i
n=size(b,1)
do i=1,n; a(i)=b(i,i); enddo
end function diagnn_d

!=============================================================================
function trace_s(b)result(s)
!=============================================================================
real(sp),dimension(:,:),intent(IN ):: b
real(sp)                           :: s
s=sum(diag(b))
end function trace_s
!=============================================================================
function trace_d(b)result(s)
!=============================================================================
real(dp),dimension(:,:),intent(IN ):: b
real(dp)                           :: s
s=sum(diag(b))
end function trace_d

!=============================================================================
function identity_i(n)result(a)
!=============================================================================
integer,intent(IN )   :: n
integer,dimension(n,n):: a
integer               :: i
a=0; do i=1,n; a(i,i)=1; enddo
end function identity_i
!=============================================================================
function identity3_i()result(a)
!=============================================================================
integer,dimension(3,3):: a
integer               :: i
a=0; do i=1,3; a(i,i)=1; enddo
end function identity3_i

!=============================================================================
function huarea_s(sa,sb)result(area)
!=============================================================================
implicit none
real(sp),intent(IN ):: sa,sb
real(sp)            :: area
real(sp)            :: ca,cb
!-----------------------------------------------------------------------------
ca=sqrt(1-sa**2)
cb=sqrt(1-sb**2)
area=asin(sa*sb/(1+ca*cb))
end function huarea_s

!=============================================================================
function huarea_d(sa,sb)result(area)
!=============================================================================
implicit none
real(dp),intent(IN ):: sa,sb
real(dp)            :: area
real(dp)            :: ca,cb
!-----------------------------------------------------------------------------
ca=sqrt(1-sa**2)
cb=sqrt(1-sb**2)
area=asin(sa*sb/(1+ca*cb))
end function huarea_d

!=============================================================================
function sarea_s(v1,v2,v3)result(area)
!=============================================================================
! Compute the area of the spherical triangle, {v1,v2,v3}, measured in the
! right-handed sense, by dropping a perpendicular to u0 on the longest side so
! that the area becomes the sum of areas of the two simpler right-angled
! triangles.
!=============================================================================
real(sp),dimension(3),intent(IN ):: v1,v2,v3
real(sp)                         :: area
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(sp)                         :: s123,a1,a2,b,d1,d2,d3
real(sp),dimension(3)            :: u0,u1,u2,u3,x,y
!=============================================================================
area=0
u1=normalized(v1); u2=normalized(v2); u3=normalized(v3)
s123=triple_product(u1,u2,u3)
if(s123==0)return

d1=dot_product(u3-u2,u3-u2)
d2=dot_product(u1-u3,u1-u3)
d3=dot_product(u2-u1,u2-u1)

! Triangle that is not degenerate. Cyclically permute, so side 3 is longest:
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
y=normalized( cross_product(u1,u2) )
b=dot_product(y,u3)
u0=normalized( u3-y*b )
x=cross_product(y,u0)
a1=-dot_product(x,u1-u0); a2= dot_product(x,u2-u0)
area=huarea(a1,b)+huarea(a2,b)

contains
!-----------------------------------------------------------------------------
   subroutine cyclic(u1,u2,u3,d1,d2,d3)
!-----------------------------------------------------------------------------
   real(sp),dimension(3),intent(INOUT):: u1,u2,u3
   real(sp),             intent(INOUT):: d1,d2,d3
   real(sp),dimension(3)              :: ut
   real(sp)                           :: dt
   dt=d1; d1=d2; d2=d3; d3=dt
   ut=u1; u1=u2; u2=u3; u3=ut
   end subroutine cyclic
end function sarea_s

!=============================================================================
function sarea_d(v1,v2,v3)result(area)
!=============================================================================
real(dp),dimension(3),intent(IN ):: v1,v2,v3
real(dp)                         :: area
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(dp)                         :: s123,a1,a2,b,d1,d2,d3
real(dp),dimension(3)            :: u0,u1,u2,u3,x,y
!=============================================================================
area=0
u1=normalized(v1); u2=normalized(v2); u3=normalized(v3)
s123=triple_product(u1,u2,u3)
if(s123==0)return

d1=dot_product(u3-u2,u3-u2)
d2=dot_product(u1-u3,u1-u3)
d3=dot_product(u2-u1,u2-u1)

! Triangle that is not degenerate. Cyclically permute, so side 3 is longest:
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
y=normalized( cross_product(u1,u2) )
b=dot_product(y,u3)
u0=normalized( u3-y*b )
x=cross_product(y,u0)
a1=-dot_product(x,u1-u0); a2= dot_product(x,u2-u0)
area=huarea(a1,b)+huarea(a2,b)

contains
!-----------------------------------------------------------------------------
   subroutine cyclic(u1,u2,u3,d1,d2,d3)
!-----------------------------------------------------------------------------
   real(dp),dimension(3),intent(INOUT):: u1,u2,u3
   real(dp),             intent(INOUT):: d1,d2,d3
   real(dp),dimension(3)              :: ut
   real(dp)                           :: dt
   dt=d1; d1=d2; d2=d3; d3=dt
   ut=u1; u1=u2; u2=u3; u3=ut
   end subroutine cyclic
end function sarea_d

!=============================================================================
subroutine gram_s(as,b,nrank,det)
!=============================================================================
real(sp),dimension(:,:),intent(IN )      :: as
real(sp),dimension(:,:),intent(OUT)      :: b
integer,                intent(OUT)      :: nrank
real(sp),               intent(OUT)      :: det
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(sp),parameter                       :: crit=1.e-5_sp
real(sp),dimension(size(as,1),size(as,2)):: a
real(sp),dimension(size(as,2),size(as,1)):: ab
real(sp),dimension(size(as,1))           :: tv,w
real(sp)                                 :: val,s,vcrit
integer                                  :: i,j,k,l,m,n
integer,dimension(2)                     :: ii
!-----------------------------------------------------------------------------
n=size(as,1)
m=size(as,2)
if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions'
a=as
b=identity(n)
det=1
val=maxval(abs(a))
if(val==0)then
   nrank=0
   return
endif
vcrit=val*crit
nrank=min(n,m)
do k=1,n
   if(k>nrank)exit
   ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) )
   ii =maxloc( abs( ab(k:m,k:n)) )+k-1
   val=maxval( abs( ab(k:m,k:n)) )
   if(val<=vcrit)then
      nrank=k-1
      exit
   endif
   i=ii(1)
   j=ii(2)
   tv=b(:,j)
   b(:,j)=-b(:,k)
   b(:,k)=tv
   tv=a(:,i)
   a(:,i)=-a(:,k)
   a(:,k)=tv
   w(k:n)=matmul( transpose(b(:,k:n)),tv )
   b(:,k)=matmul(b(:,k:n),w(k:n) )
   s=dot_product(b(:,k),b(:,k))
   s=sqrt(s)
   if(w(k)<0)s=-s
   det=det*s
   b(:,k)=b(:,k)/s
   do l=k,n
      do j=l+1,n
         s=dot_product(b(:,l),b(:,j))
         b(:,j)=normalized( b(:,j)-b(:,l)*s )
      enddo
   enddo
enddo
end subroutine gram_s

!=============================================================================
subroutine gram_d(as,b,nrank,det)
!=============================================================================
real(dp),dimension(:,:),intent(IN )      :: as
real(dp),dimension(:,:),intent(OUT)      :: b
integer,                intent(OUT)      :: nrank
real(dp),               intent(OUT)      :: det
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(dp),parameter                       :: crit=1.e-9_dp
real(dp),dimension(size(as,1),size(as,2)):: a
real(dp),dimension(size(as,2),size(as,1)):: ab
real(dp),dimension(size(as,1))           :: tv,w
real(dp)                                 :: val,s,vcrit
integer                                  :: i,j,k,l,m,n
integer,dimension(2)                     :: ii
!-----------------------------------------------------------------------------
n=size(as,1)
m=size(as,2)
if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions'
a=as
b=identity(n)
det=1
val=maxval(abs(a))
if(val==0)then
   nrank=0
   return
endif
vcrit=val*crit
nrank=min(n,m)
do k=1,n
   if(k>nrank)exit
   ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) )
   ii =maxloc( abs( ab(k:m,k:n)) )+k-1
   val=maxval( abs( ab(k:m,k:n)) )
   if(val<=vcrit)then
      nrank=k-1
      exit
   endif
   i=ii(1)
   j=ii(2)
   tv=b(:,j)
   b(:,j)=-b(:,k)
   b(:,k)=tv
   tv=a(:,i)
   a(:,i)=-a(:,k)
   a(:,k)=tv
   w(k:n)=matmul( transpose(b(:,k:n)),tv )
   b(:,k)=matmul(b(:,k:n),w(k:n) )
   s=dot_product(b(:,k),b(:,k))
   s=sqrt(s)
   if(w(k)<0)s=-s
   det=det*s
   b(:,k)=b(:,k)/s
   do l=k,n
      do j=l+1,n
         s=dot_product(b(:,l),b(:,j))
         b(:,j)=normalized( b(:,j)-b(:,l)*s )
      enddo
   enddo
enddo
end subroutine gram_d

!=============================================================================
subroutine plaingram_s(b,nrank)
!=============================================================================
! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only.
real(sp),dimension(:,:),intent(INOUT)    :: b
integer,                intent(  OUT)    :: nrank
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(sp),parameter                       :: crit=1.e-5_sp
real(sp)                                 :: val,vcrit
integer                                  :: j,k,n
!-----------------------------------------------------------------------------
n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square'
val=maxval(abs(b))
nrank=0
if(val==0)then
   b=0
   return
endif
vcrit=val*crit
do k=1,n
   val=sqrt(dot_product(b(:,k),b(:,k)))
   if(val<=vcrit)then
      b(:,k:n)=0
      return
   endif
   b(:,k)=b(:,k)/val
   nrank=k
   do j=k+1,n
      b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j))
   enddo
enddo
end subroutine plaingram_s

!=============================================================================
subroutine plaingram_d(b,nrank)
!=============================================================================
! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only.
real(dp),dimension(:,:),intent(INOUT)    :: b
integer,                intent(  OUT)    :: nrank
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(dp),parameter                       :: crit=1.e-9_dp
real(dp)                                 :: val,vcrit
integer                                  :: j,k,n
!-----------------------------------------------------------------------------
n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square'
val=maxval(abs(b))
nrank=0
if(val==0)then
   b=0
   return
endif
vcrit=val*crit
do k=1,n
   val=sqrt(dot_product(b(:,k),b(:,k)))
   if(val<=vcrit)then
      b(:,k:n)=0
      return
   endif
   b(:,k)=b(:,k)/val
   nrank=k
   do j=k+1,n
      b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j))
   enddo
enddo
end subroutine plaingram_d

end module peuc


module gaussian_model
contains
  subroutine gaussian(output, mu, sigma, k, seed)
    integer, intent(in) :: k, seed
    real(8), intent(in) :: mu, sigma
    real(8), intent(out) :: output(k)

    integer :: i, n
    real(8) :: r, theta
    real(8), dimension(:), allocatable :: temp
    integer(4), dimension(:), allocatable :: seed_arr

    ! get random seed array size and fill seed_arr with provided seed
    call random_seed(size = n)
    allocate(seed_arr(n))
    seed_arr = seed
    call random_seed(put = seed_arr)

    ! create 2k random numbers uniformly from [0,1]
    if(allocated(temp)) then
       deallocate(temp)
    end if
    allocate(temp(k*2))
    call random_number(temp)

    ! Use Box-Muller transfrom to create normally distributed variables
    do i = 1, k
       r = (-2.0 * log(temp(2*i-1)))**0.5
       theta = 2 * 3.1415926 * temp(2*i)
       output(i) = mu + sigma * r * sin(theta)
    end do
  end subroutine gaussian
end module gaussian_model

program main
  use gaussian_model
  implicit none

  integer, parameter :: k = 100
  integer :: seed = 9, i
  real(8) :: mu = 10.0, sigma = 2.0
  real(8) :: output(k)

  call gaussian(output, mu, sigma, k, seed)

  do i = 1, k
     write(*,*) output(i)
  end do
end program main


module dlg

contains
    function dlg_pDeriv ( x, y, array, dir ) result ( dArray )
        implicit none

        real, dimension (:,:), allocatable :: dArray
        integer :: nX, nY, i, j
        integer, intent(IN) :: dir
        real, intent(IN) :: array (:,:), x(:), y(:)
        real :: dS

        nX  = size ( array, 1 )
        nY  = size ( array, 2 )

        allocate ( dArray ( nX, nY ) )
        dArray  = 0.0

        if ( dir == 2 ) then

            do i=1,nX
                do j=1,nY

                    if ( j > 1 .AND. j < nY ) then

                        dS = ((y(j+1)-y(j)) + (y(j)-y(j-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( array(i,j+1) - array(i,j-1) )

                    elseif ( j == 1 ) then

                        dS = ((y(j+1)-y(j)) + (y(j+2)-y(j+1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            -3.0 * array(i,j) + 4.0 * array(i,j+1) &
                            - array(i,j+2) )

                    elseif ( j == nY ) then

                        dS = ((y(j-1)-y(j-2)) + (y(j)-y(j-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            3.0 * array(i,j) - 4.0 * array(i,j-1) &
                            + array(i,j-2) )

                    endif

                enddo
            enddo

        elseif ( dir == 1 ) then

            do i=1,nX
                do j=1,nY

                    if ( i > 1 .AND. i < nX ) then

                        dS = ((x(i+1)-x(i)) + (x(i)-x(i-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( array(i+1,j) - array(i-1,j) )

                    elseif ( i == 1 ) then

                        dS = ((x(i+1)-x(i)) + (x(i+2)-x(i+1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            -3.0 * array(i,j) + 4.0 * array(i+1,j) &
                            - array(i+2,j) )

                    elseif ( i == nX ) then

                        dS = ((x(i-1)-x(i-2)) + (x(i)-x(i-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            3.0 * array(i,j) - 4.0 * array(i-1,j) &
                            + array(i-1,j) )

                    endif

                enddo
            enddo

        end if

    end function dlg_pDeriv

end module dlg


program check_array_handler
    use fsvd_mod
    implicit none
    integer, parameter :: nrow = 6, ncol = 5, dp = kind(1.0d0)
    real(dp) :: x(nrow, ncol), y(nrow, ncol)
    integer :: xshape(2)
    integer :: i, j
    real(dp) :: va(ncol), vb(nrow), res(nrow)
!   for SVD
    integer :: k
    real(dp), allocatable :: U(:, :), S(:), VT(:, :)

    do i = 1, ncol
        do j = 1, nrow
            x(j, i) = 3.d0 * i
        end do
    end do

    xshape = shape(x)
    write (6, *) "Rows in x =", size(x, 1)
    write (6, *) "Columns in x =", size(x, 2)

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | Array division"
    call array_division(x, 3.d0, nrow, ncol, y)
    write (6, *) "Output array =>"
    call print_array2d(y, nrow, ncol)

    do i = 1, ncol
        va(i) = 1.d0 * i
    end do

    do i = 1, nrow
        vb(i) = 1.d0
        res(i) = 1.d0
    end do

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | dgemv from subroutine"
    call sub_dgemv(x, va, vb, 3.d0, 0.d0, nrow, ncol, res)
    write (6, *) "Input vector =>"
    call print_vector(va, ncol)
    write (6, *) "Output [3.d0 * dot(x, y)] =>"
    call print_vector(res, nrow)

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | SVD from subroutine"
      DATA             x/                    &
       8.79, 6.11,-9.15, 9.57,-3.49, 9.84,   &
       9.93, 6.91,-7.93, 1.64, 4.02, 0.15,   &
       9.83, 5.04, 4.86, 8.83, 9.80,-8.99,   &
       5.45,-0.27, 4.85, 0.74,10.00,-6.02,   &
       3.16, 7.98, 3.01, 5.80, 4.27,-5.31    &
                       /
    write (6, *) "Input matrix =>"
    call print_array2d(x, nrow, ncol)
    k = min(nrow, ncol)
    allocate (U(nrow, k), S(k), VT(k, ncol))
    do j = 1, k
        do i = 1, nrow
            U(i, j) = 0.d0
        end do
    end do
    do j = 1, ncol
        do i = 1, k
            VT(i, j) = 0.d0
        end do
    end do
    do i = 1, k
        S(i) = 0.d0
    end do
    call sub_dgesvd(x, k, nrow, ncol, U, S, VT)
    call print_svd_result(U, S, VT, k, nrow, ncol)

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | SVD from module"
    write (6, *) "Input matrix =>"
    call print_array2d(x, nrow, ncol)
    call print_extmod()
!    call sub_dgesvd(x, k, nrow, ncol, U, S, VT)
    call fsvd_mod_dgesvd(x, k, nrow, ncol, U, S, VT)
    call print_svd_result(U, S, VT, k, nrow, ncol)

end program check_array_handler

subroutine print_svd_result(U, S, VT, k, nrow, ncol)
    implicit none
    integer, parameter :: dp = kind(1.0d0)
    integer, intent(in) :: k, nrow, ncol
    real(dp), intent(in) :: U(nrow, k), S(k), VT(k, ncol)
    write (6, *) "Output U =>"
    call print_array2d(U, nrow, k)
    write (6, *) "Output S =>"
    call print_vector(S, k)
    write (6, *) "Output transpose(V) =>"
    call print_array2d(VT, k, ncol)
end subroutine print_svd_result


program main
    implicit none

    integer :: limit, i, prod, min_value
    integer, dimension(:), allocatable :: numbers

    limit = 20
    allocate(numbers(limit))

    prod = 1
    do i = 1, limit
        if (isPrime(i)) then
            prod = prod * i
            numbers(i) = 1
        else
            numbers(i) = i
        end if
    end do

    min_value = prod
    do while (count(mod(min_value, numbers) /= 0) /= 0)
        min_value = min_value + prod
    end do

    print *, min_value

contains
function isPrime(number)
        implicit none
        integer, intent(in) :: number
        logical :: isPrime
        integer :: i

        isPrime = .True.
        do i = 2, number / 2
            if (mod(number, i) .eq. 0) then
                isPrime = .FALSE.
                exit
            end if
        end do
        ! isPrime = .FALSE.

    end function isPrime
end program main


C$Procedure  TRACEG ( Trace of a matrix, general dimension )

      DOUBLE PRECISION FUNCTION  TRACEG ( MATRIX, NDIM )

C$ Abstract
C
C      Return the trace of a square matrix of arbitrary dimension.
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      MATRIX
C
C$ Declarations

      INTEGER            NDIM
      DOUBLE PRECISION   MATRIX ( NDIM,NDIM )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      MATRIX     I     NDIM x NDIM matrix of double precision numbers.
C      NDIM       I     Dimension of the matrix.
C      TRACEG     O     The trace of MATRIX.
C
C$ Detailed_Input
C
C      MATRIX  is a double precision square matrix of arbitrary
C              dimension.  The input matrix must be square or else
C              the concept is meaningless.
C
C      NDIM    is the dimension of MATRIX.
C
C$ Detailed_Output
C
C      TRACEG  is the trace of MATRIX, i.e. it is the sum of the
C              diagonal elements of MATRIX.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      TRACEG simply executes in FORTRAN code the following loop:
C
C      TRACEG = Summation from I = 1 to NDIM of MATRIX(I,I)
C
C      No error detection or correction is implemented within this
C      function.
C
C$ Examples
C
C                            | 3   5   7 |
C      Suppose that MATRIX = | 0  -2   8 |  (with NDIM = 3), then
C                            | 3   0  -1 |
C
C      TRACEG (MATRIX, 3) = 0.  (which is the sum of 3, -2 and -1).
C
C$ Restrictions
C
C      No checking is performed to guard against floating point overflow
C      or underflow.  This routine should probably not be used if the
C      input matrix is expected to have large double precision numbers
C      along the diagonal.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
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.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     trace of a nxn_matrix
C
C-&

      INTEGER         I

      TRACEG = 0.0D0
      DO I = 1,NDIM
         TRACEG = TRACEG + MATRIX(I,I)
      END DO

      RETURN
      END


module PlaneGeomModule
!------------------------------------------------------------------------------
! Lagrangian Particle / Panel Method
!------------------------------------------------------------------------------
!
!> @author
!> Peter Bosler, Department of Mathematics, University of Michigan
!
!> @defgroup PlaneGeom Planar Geometry
!> defines functions for performing geometric calculations in the plane
!
!
! DESCRIPTION:
!> @file
!> defines functions for performing geometric calculations in the plane
!
!------------------------------------------------------------------------------

use NumberKindsModule

implicit none

public

contains
!----------------
! Basic geometry : length, area, centers of mass, etc.
!----------------

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Euclidean distance between two points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @return Distance double precision real, scalar distance between xyA and xyB
!------------------------------------------------------------------------------
pure function Distance( xyA, xyB)
	real(kreal) :: Distance
	real(kreal), intent(in) :: xyA(2), xyB(2)
	Distance = sqrt( sum( (xyB - xyA)*(xyB - xyA) ) )
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Find midpoint of line segment connecting two points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @return Midpoint double precision real size(2)
!------------------------------------------------------------------------------
pure function Midpoint( xyA, xyB )
	real(kreal) :: Midpoint(2)
	real(kreal), intent(in) :: xyA(2), xyB(2)
	Midpoint = 0.5_kreal*(xyA + xyB)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Cetroid of a triangle created by three points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @param[in] xyC double precision real size(2); vector in the plane
!> @return TriCentroid double precision real size(2)
!------------------------------------------------------------------------------
pure function TriCentroid( xyA, xyB, xyC )
	real(kreal) :: TriCentroid(2)
	real(kreal), intent(in) :: xyA(2), xyB(2), xyC(2)
	TriCentroid = (xyA + xyB + xyC)/3.0_kreal
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Cetroid of a quadrilateral created by four points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @param[in] xyC double precision real size(2); vector in the plane
!> @param[in] xyD double precision real size(2); vector in the plane
!> @return QuadCentroid double precision real size(2)
!------------------------------------------------------------------------------
pure function QuadCentroid( xyA, xyB, xyC, xyD )
	real(kreal) :: QuadCentroid(2)
	real(kreal), intent(in) :: xyA(2), xyB(2), xyC(2), xyD(2)
	QuadCentroid = 0.25_kreal*(xyA + xyB + xyC + xyD)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief area of a planar triangle whose vertices are the input vectors
!
!> @ingroup PlaneGeom
!
!> @param[in] xA double precision real size(2); vector in the plane
!> @param[in] xB double precision real size(2); vector in the plane
!> @param[in] xC double precision real size(2); vector in the plane
!> @return TriArea double precision real; scalar area of triangle
!------------------------------------------------------------------------------
pure function TriArea( xA, xB, xC )
	real(kreal) :: TriArea
	real(kreal), intent(in) :: xA(2), xB(2), xC(2)
	TriArea = 0.5_kreal*abs( -xB(1)*xA(2) + xC(1)*xA(2) + xA(1)*xB(2) - xC(1)*xB(2) - xA(1)*xC(2) + xB(1)*xC(2))
end function

!----------------
! Misc. functions
!----------------
!

end module


function logspace(a,b,n) result(x)
! Returns row vector x of n points logorithmically spaced between [a,b]
! === Parameters ===
! a - (real) left endpoin
! b - (real) right endpoint
! === Output ===
! x - (array) array of equispaced points
real(kind=8), intent(in)  :: a,b
integer,      intent(in)  :: n
real(kind=8), allocatable :: x(:)
integer :: i
real(kind=8) :: s
allocate(x(n))
s = (b-a)/(n-1.d0) ! scaling factor
do i=1,n
    x(i) = 10.d0**(a + s*(i-1.d0))
enddo
end function logspace