subroutine CilmPlus(cilm, gridin, lmax, nmax, mass, d, rho, gridtype, w, zero, plx, n, dref)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will compute the potential coefficients associated
!	with the input gridded relief using the method of Wieczorek and
!	Phillips (1998). The input grid must contain the degree-0 term
!	and the computed coefficients will be referenced to the corresonding
!	degree-0 radius. Note that the array plx is optional, and should not
!	be precomputed when memory is an issue (i.e., lmax>360).
!
!	Calling Parameters
!		IN
!			gridin:		Input grid to be transformed to spherical
!					harmonics.
!			lmax:		Maximum spherical harmonic degree to compute. For gridtype 3 and 4,
!					this must be less than or equal to N/2 - 1.
!			nmax:		Order of expansion.
!			mass:		Mass of planet.
!			rho:		density of the relief.
!			gridtype	1 = Gauss-Legendre quadrature grid corresponding to LMAX.
!					2 = N by N Driscoll and Healy grid corresponding to LMAX.
!					3 = N by 2N Driscoll and Healy grid corresponding to LMAX.
!					(4 = 2D Cartesian using MakeGrid2D is not implemented).
!		OUT
!			cilm:		Output spherical harmonic coefficients with dimensions (2, lmax+1, lmax+1).
!			d:	 	The radius that the coefficients are referenced
!					to. This parameter corresponds to the degree zero term of the data.
!		OPTIONAL
!			w:		Gauss-Legendre points used in the integrations of dimension lmax+1.
!			zero:		Array of dimension lmax+1 that contains the latitudinal
!					gridpoints used in the Gauss-Legendre quadrature integration
!					scheme. Only needed when PLX is not included.
!					(Determined from a call to PreCompute).
!			plx:		Input array of Associated Legendre Polnomials computed
!					at the Gauss points (determined from a call to
!					PreCompute). If this is not included, then the optional
!					array zero MUST be inlcuded.
!			N:		Number of latitude points in the Driscoll and Healy grid. Required for Gridtype 2 and 3
!			dref:		The reference radius used to be used when calculating the spherical
!					harmonic coefficients. If not specified, this will be set equal to the
!					mean radius of GRIDIN.
!
!	All units assumed to be SI.
!
!	Dependencies:		NGLQSH, SHExpandGLQ, SHExpandDH
!
!	Written by Mark Wieczorek 2003
!		September 3, 2005. Modifed so that the array plx is now optional.
!		April 2009. Added the option to use N by N and N by 2N Driscoll and Healy (1994) grids.
!			GRIDTYPE must now be specified, and W is now defined as an optional parameter.
!			Added the optional parameter DREF, which sets the reference radius of the expansion.
!
!	Copyright (c) 2005-2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: NGLQSH, SHExpandGLQ, SHExpandDH

	implicit none

	real*8, intent(in) :: 	gridin(:,:), mass, rho
	real*8, intent(in), optional :: w(:), zero(:), plx(:,:), dref
	real*8, intent(out) ::	cilm(:,:,:), d
	integer, intent(in) ::	lmax, nmax, gridtype
	integer, intent(in), optional :: n
	real*8 ::		prod, pi
	real*8, allocatable ::	cilmn(:, :, :), grid(:, :)
	integer ::		j, l, k, nlat, nlong, astat(2), lmax_dh

	pi = acos(-1.0d0)

	if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. size(cilm(1,1,:)) < lmax+1) then
		print*, "Error --- CilmPlus"
		print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if (gridtype == 4) then
		print*, "Error --- CilmPlus"
		print*, "GRIDTYPE 4 (Cartesian obtained from MakeGrid2D) is not allowed."
		stop

	elseif (gridtype == 1) then
		if (present(n)) then
			print*, "Error --- CilmPlus"
			print*, "N can not be present when using GLQ grids."
			stop
		endif

		if (present(w) .and. present(zero) .and. present(plx)) then
			print*, "Error --- CilmPlus"
			print*, "For GLQ grids, either W and ZERO or W and PLX must be present, but not all three."
			stop
		elseif (present(w) .and. present(zero)) then
			if (size(w) < lmax + 1) then
				print*, "Error --- CilmPlus"
				print*, "W must be dimensioned as (LMAX+1) where LMAX is ", lmax
				print*, "Input dimension is ", size(w)
				stop
			endif

			if (size(zero) < lmax + 1) then
				print*, "Error --- CilmPlus"
				print*, "ZERO must be dimensioned as (LMAX+1) where LMAX is ", lmax
				print*, "Input dimension is ", size(zero)
				stop
			endif

		elseif (present(plx) .and. present(w)) then
			if (size(w) < lmax + 1) then
				print*, "Error --- CilmPlus"
				print*, "W must be dimensioned as (LMAX+1) where LMAX is ", lmax
				print*, "Input dimension is ", size(w)
				stop
			endif

			if (size(plx(:,1)) < lmax+1 .or. size(plx(1,:)) < (lmax+1)*(lmax+2)/2) then
				print*, "Error --- CilmPlus"
				print*, "PLX must be dimensioned as (LMAX+1, (LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
				print*, "Input dimension is ", size(plx(:,1)), size(plx(1,:))
				stop
			endif

		else
			print*, "Error --- CilmPlus"
			print*, "For GLQ grids, either W and ZERO or W and PLX must be present"
			stop
		endif

	elseif (gridtype == 2) then
		if (present(w) .or. present(zero) .or. present(plx)) then
			print*, "Error --- CilmPlus"
			print*, "W, ZERO and PLX can not be present for Driscoll-Healy grids."
			stop
		elseif (.not.present(N)) then
			print*, "Error --- CilmPlus"
			print*, "N must be present when GRIDTYPE is 2 or 3."
			stop
		endif

	elseif (gridtype == 3) then
		if (present(w) .or. present(zero) .or. present(plx)) then
			print*, "Error --- CilmPlus"
			print*, "W, ZERO and PLX can not be present for Driscoll-Healy grids."
			stop
		elseif (.not.present(N)) then
			print*, "Error --- CilmPlus"
			print*, "N must be present when GRIDTYPE is 2 or 3."
			stop
		endif

	else
		print*, "Error --- CilmPlus"
		print*, "GRIDTYPE must be 2 (GLQ), 3 (NxN) or 4 (Nx2N)"
		print*, "Input value is ", gridtype
		stop
	endif

	if (gridtype == 1) then
		nlat = NGLQSH(lmax) !  lmax+1
		nlong = 2*lmax+1
	elseif (gridtype == 2) then
		nlat = N
		nlong = N
		lmax_dh = N/2 - 1
		if (lmax > lmax_dh) then
			print*, "Error --- CilmPlus"
			print*, "For Driscoll-Healy grids, LMAX must be less than or equal to N/2 -1, where N is ", N
			print*, "Input value of LMAX is ", lmax
			stop
		endif
	elseif (gridtype == 3) then
		nlat = N
		nlong = 2*N
		lmax_dh = N/2 - 1
		if (lmax > lmax_dh) then
			print*, "Error --- CilmPlus"
			print*, "For Driscoll-Healy grids, LMAX must be less than or equal to N/2 -1, where N is ", N
			print*, "Input value of LMAX is ", lmax
			stop
		endif
	endif

	if (size(gridin(1,:)) < nlong .or. size(gridin(:,1)) < nlat) then
		print*, "Error --- CilmPlus"
		if (gridtype == 2) then
			print*, "GRIDIN must be dimensioned as (LMAX+1, 2*LMAX+1) where LMAX is ", lmax
			print*, "Input dimension is ", size(gridin(1,:)), size(gridin(:,1))
			stop
		elseif (gridtype == 3) then
			print*, "GRIDIN must be dimensioned as (N, N) where N is ", n
			print*, "Input dimension is ", size(gridin(1,:)), size(gridin(:,1))
			stop
		elseif (gridtype == 4) then
			print*, "GRIDIN must be dimensioned as (N, 2N) where N is ", n
			print*, "Input dimension is ", size(gridin(1,:)), size(gridin(:,1))
			stop
		endif
	endif

	allocate(cilmn(2, lmax+1, lmax+1), stat=astat(1))
	allocate(grid(nlat, nlong), stat=astat(2))
	if (astat(1) /= 0 .or. astat(2) /= 0) then
		print*, "Error --- CilmPlus"
		print*, "Problem allocating arrays CILMN and GRID", astat(1), astat(2)
		stop
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Do the expansion.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	grid(1:nlat, 1:nlong) = gridin(1:nlat,1:nlong)
	cilm = 0.0d0
	cilmn = 0.0d0

	! Do k = 1 terms first
	select case(gridtype)
		case(1)
			if (present(plx)) then
				call SHExpandGLQ(cilmn, lmax, grid, w, plx = plx, norm = 1, csphase = 1)
			else
				call SHExpandGLQ(cilmn, lmax, grid, w, zero=zero, norm = 1, csphase = 1)
			endif
		case(2); call SHExpandDH(grid, n, cilmn, lmax_dh, norm = 1, sampling = 1, csphase = 1, lmax_calc = lmax)
		case(3); call SHExpandDH(grid, n, cilmn, lmax_dh, norm = 1, sampling = 2, csphase = 1, lmax_calc = lmax)
	end select

	if (present(dref)) then
		d = dref
	else
		d = cilmn(1,1,1)	! use mean radius of relief for reference sphere
	endif

	grid = grid - d
	cilmn(1,1,1) = cilmn(1,1,1) - d
	cilmn = cilmn/d

	do l=0, lmax
		cilm(:,l+1,1:l+1) = 4.0d0*pi*rho*(d**3)*cilmn(:,l+1,1:l+1) /mass /dble(2*l+1)
	enddo

	do k=2, nmax
		select case(gridtype)
			case(1)
				if (present(plx)) then
					call SHExpandGLQ(cilmn, lmax, (grid/d)**k, w, plx=plx, norm = 1, csphase = 1)
				else
					call SHExpandGLQ(cilmn, lmax, (grid/d)**k, w, zero=zero, norm = 1, csphase = 1)
				endif
			case(2); call SHExpandDH((grid/d)**k, n, cilmn, lmax_dh, norm = 1, sampling = 1, csphase = 1, lmax_calc = lmax)
			case(3); call SHExpandDH((grid/d)**k, n, cilmn, lmax_dh, norm = 1, sampling = 2, csphase = 1, lmax_calc = lmax)
		end select

		do l = 0, lmax
			prod = 4.0d0*pi*rho*(d**3)/mass
			do j=1, k
				prod = prod * dble(l+4-j)
			enddo
			prod = prod/( dble(2*l+1) * dble(l+3) * dble(fact(k)) )

			cilm(:,l+1,1:l+1) = cilm(:,l+1,1:l+1) + cilmn(:,l+1,1:l+1)*prod
		enddo
	enddo

	deallocate(cilmn)
	deallocate(grid)

	contains

		function fact(i)
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	This function computes the factorial of an integer
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
			implicit none
			integer ::	i, j, fact

			if (i == 0) then
				fact = 1
			elseif (i .lt. 0) then
				print*, "Argument to FACT must be positive"
				stop
			else
				fact = 1
				do j = 1, i
					fact = fact * j
				enddo
			endif

		end function fact

end subroutine CilmPlus


        module lcg

            implicit none

            private
            save

            integer(8) :: prn_seed0  ! original seed
            integer(8) :: prn_seed   ! current seed
            integer(8) :: prn_mult   ! multiplication factor, g
            integer(8) :: prn_add    ! additive factor, c
            integer    :: prn_bits   ! number of bits, M
            integer(8) :: prn_mod    ! 2^M
            integer(8) :: prn_mask   ! 2^M - 1
            integer(8) :: prn_stride ! stride between particles
            real(8)    :: prn_norm   ! 2^(-M)

            public :: prn
            public :: seed
            public :: initialize_prng
            public :: set_particle_seed
            public :: prn_skip

        contains

!===============================================================================
! SEED returns current seed value
!===============================================================================

            function seed() result(the_seed)

            integer(8) :: the_seed

            the_seed = prn_seed

            end function seed

!===============================================================================
! PRN generates a pseudo-random number using a linear congruential generator
!===============================================================================

            function prn() result(pseudo_rn)

            real(8) :: pseudo_rn

            ! This algorithm uses bit-masking to find the next integer(8) value to be
            ! used to calculate the random number

            prn_seed = iand(prn_mult*prn_seed + prn_add, prn_mask)

            ! Once the integer is calculated, we just need to divide by 2**m,
            ! represented here as multiplying by a pre-calculated factor

            pseudo_rn = prn_seed * prn_norm

            end function prn

!===============================================================================
! INITIALIZE_PRNG sets up the random number generator, determining the seed and
! values for g, c, and m.
!===============================================================================

            subroutine initialize_prng()

            use global, only: seed

            prn_seed0  = seed
            prn_seed   = prn_seed0
            prn_mult   = 2806196910506780709_8
            prn_add    = 1_8
            prn_bits   = 63
            prn_mod    = ibset(0_8, prn_bits)  ! clever way of calculating 2**bits
            prn_mask   = prn_mod - 1_8
            prn_stride = 152917_8
            prn_norm   = 2._8**(-prn_bits)

            end subroutine initialize_prng

!===============================================================================
! SET_PARTICLE_SEED sets the seed to a unique value based on the ID of the
! particle
!===============================================================================

            subroutine set_particle_seed(id)

            integer(8), intent(in) :: id

            prn_seed = prn_skip_ahead(id*prn_stride, prn_seed0)

            end subroutine set_particle_seed

!===============================================================================
! PRN_SKIP advances the random number seed 'n' times from the current seed
!===============================================================================

            subroutine prn_skip(n)

            integer(8), intent(in) :: n ! number of seeds to skip

            prn_seed = prn_skip_ahead(n, prn_seed)

            end subroutine prn_skip

!===============================================================================
! PRN_SKIP_AHEAD advances the random number seed 'skip' times. This is usually
! used to skip a fixed number of random numbers (the stride) so that a given
! particle always has the same starting seed regardless of how many processors
! are used
!===============================================================================

            function prn_skip_ahead(n, seed) result(new_seed)

            integer(8), intent(in) :: n        ! number of seeds to skip
            integer(8), intent(in) :: seed     ! original seed
            integer(8)             :: new_seed ! new seed

            integer(8) :: nskip ! positive number of seeds to skip
            integer(8) :: g     ! original multiplicative constant
            integer(8) :: c     ! original additive constnat
            integer(8) :: g_new ! new effective multiplicative constant
            integer(8) :: c_new ! new effective additive constant

            ! In cases where we want to skip backwards, we add the period of the random
            ! number generator until the number of PRNs to skip is positive since
            ! skipping ahead that much is the same as skipping backwards by the original
            ! amount

            nskip = n
            do while (nskip < 0_8)
                nskip = nskip + prn_mod
            end do

            ! Make sure nskip is less than 2^M
            nskip = iand(nskip, prn_mask)

            ! The algorithm here to determine the parameters used to skip ahead is
            ! described in F. Brown, "Random Number Generation with Arbitrary Stride,"
            ! Trans. Am. Nucl. Soc. (Nov. 1994). This algorithm is able to skip ahead in
            ! O(log2(N)) operations instead of O(N). Basically, it computes parameters G
            ! and C which can then be used to find x_N = G*x_0 + C mod 2^M.

            ! Initialize constants
            g     = prn_mult
            c     = prn_add
            g_new = 1
            c_new = 0
            BIT_LOOP: do while (nskip > 0_8)

                ! Check if least significant bit is 1
                if (btest(nskip,0)) then
                    g_new = iand(g_new*g, prn_mask)
                    c_new = iand(c_new*g + c, prn_mask)
                endif
                c = iand((g+1)*c, prn_mask)
                g = iand(g*g, prn_mask)

                ! Move bits right, dropping least significant bit
                nskip = ishft(nskip, -1)
            end do BIT_LOOP

            ! With G and C, we can now find the new seed
            new_seed = iand(g_new*seed + c_new, prn_mask)

            end function prn_skip_ahead

        end module lcg


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_rotdenmat
      use m_juDFT
      CONTAINS
      SUBROUTINE rot_den_mat(alph,beta,rho11,rho22,rho21)
c***********************************************************************
c This subroutine rotates the direction of the magnetization of the
c density matrix by multiplying with the unitary 2x2 spin rotation
c matrix. --> U*rho*U^dagger
c Philipp Kurz 2000-02-03
c new method for improved stability (l_new=t) gb'19
c***********************************************************************

      use m_constants
      IMPLICIT NONE

C     .. Scalar Arguments ..
      REAL, INTENT    (IN) :: alph,beta
      REAL, INTENT    (INOUT) :: rho11
      REAL, INTENT    (INOUT) :: rho22
      COMPLEX, INTENT (INOUT) :: rho21
C     ..
C     .. Local Scalars ..
      INTEGER ispin
      REAL eps,r11n,r22n
      COMPLEX r21n
      LOGICAL l_new
C     ..
C     .. Local Arrays ..
      COMPLEX u2(2,2),rho(2,2),rhoh(2,2)
C     ..
      l_new = .true.

      IF (l_new) THEN

      r11n = 0.5*(1.0+cos(beta))*rho11 - sin(beta)*real(rho21) +
     +       0.5*(1.0-cos(beta))*rho22
      r22n = 0.5*(1.0-cos(beta))*rho11 + sin(beta)*real(rho21) +
     +       0.5*(1.0+cos(beta))*rho22
      r21n = CMPLX(cos(alph),+sin(alph))*(sin(beta)*(rho11-rho22) +
     +       2.0*(cos(beta)*real(rho21)+cmplx(0.0,aimag(rho21))))*0.5

      rho11 = r11n
      rho22 = r22n
      rho21 = r21n

      ELSE

      eps = 1.0e-10

c---> set up the unitary 2x2 spin rotation matrix U^(2)
      u2(1,1) =  exp(-ImagUnit*alph/2)*cos(beta/2)
      u2(1,2) = -exp(-ImagUnit*alph/2)*sin(beta/2)
      u2(2,1) =  exp( ImagUnit*alph/2)*sin(beta/2)
      u2(2,2) =  exp( ImagUnit*alph/2)*cos(beta/2)

      rho(1,1) = cmplx(rho11,0.0)
      rho(2,2) = cmplx(rho22,0.0)
      rho(2,1) =       rho21
      rho(1,2) = conjg(rho21)

c---> first calculate U*rho
      rhoh(1,1) = u2(1,1)*rho(1,1) + u2(1,2)*rho(2,1)
      rhoh(1,2) = u2(1,1)*rho(1,2) + u2(1,2)*rho(2,2)
      rhoh(2,1) = u2(2,1)*rho(1,1) + u2(2,2)*rho(2,1)
      rhoh(2,2) = u2(2,1)*rho(1,2) + u2(2,2)*rho(2,2)
c---> now calculate (U*rho)*U^dagger
      rho(1,1) = rhoh(1,1)*conjg(u2(1,1))
     +         + rhoh(1,2)*conjg(u2(1,2))
      rho(1,2) = rhoh(1,1)*conjg(u2(2,1))
     +         + rhoh(1,2)*conjg(u2(2,2))
      rho(2,1) = rhoh(2,1)*conjg(u2(1,1))
     +         + rhoh(2,2)*conjg(u2(1,2))
      rho(2,2) = rhoh(2,1)*conjg(u2(2,1))
     +         + rhoh(2,2)*conjg(u2(2,2))

c---> check wether the diagonal elements of the rotated density
c---> are real.
      DO ispin = 1,2
         IF (aimag(rho(ispin,ispin)).GT.eps) THEN
            CALL juDFT_error("rotation of mag. failed",calledby
     +           ="rot_den_mat",hint=
     +        'After the rotation of the density matrix in the '//
     +       'muffin-tin sphere one diagonal element of the '//
     +       '(hermitian) density matrix is not real. That means '//
     +       'that the density matrix was probably damaged.')
         ENDIF
      ENDDO

      rho11 = real(rho(1,1))
      rho22 = real(rho(2,2))
      rho21 =      rho(2,1)

      ENDIF

      END SUBROUTINE rot_den_mat
      END MODULE m_rotdenmat


    subroutine sea_omega
!   ********************
    use constante, only: dens
    implicit none
    include 'combine_foam.inc'

    do j=1,nbasin-1
        omega(j)=var(4,j)*co3(j)/akc(j)
        omega_ara(j)=omega(j)/1.5
        call lyso(omega(j),temp_box(j),salin(j) &
                  ,dens,dplysc(j),dplysa(j))

    enddo
    return
    end


!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright (C) 2000 - 2018  CP2K developers group                                               !
!--------------------------------------------------------------------------------------------------!

! **************************************************************************************************
!> \par History
!>      09.2004 created [tlaino]
!> \author Teodoro Laino
! **************************************************************************************************
MODULE qmmm_util
   USE kinds,                           ONLY: dp
   USE mathconstants,                   ONLY: pi

   IMPLICIT NONE
   PRIVATE

   LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .FALSE.
   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qmmm_util'
   PUBLIC :: spherical_cutoff_factor

CONTAINS

! **************************************************************************************************
!> \brief Computes a spherical cutoff factor for the QMMM interactions
!> \param spherical_cutoff ...
!> \param rij ...
!> \param factor ...
!> \par History
!>      08.2008 created
!> \author Teodoro Laino
! **************************************************************************************************
   SUBROUTINE spherical_cutoff_factor(spherical_cutoff, rij, factor)
      REAL(KIND=dp), DIMENSION(2), INTENT(IN)            :: spherical_cutoff
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      REAL(KIND=dp), INTENT(OUT)                         :: factor

      CHARACTER(len=*), PARAMETER :: routineN = 'spherical_cutoff_factor', &
         routineP = moduleN//':'//routineN

      REAL(KIND=dp)                                      :: r, r0

      r = SQRT(DOT_PRODUCT(rij, rij))
      r0 = spherical_cutoff(1)-20.0_dp*spherical_cutoff(2)
      factor = 0.5_dp*(1.0_dp-TANH((r-r0)/spherical_cutoff(2)))

   END SUBROUTINE spherical_cutoff_factor

END MODULE qmmm_util


program molecular_dynamics_3d

use omp_lib

use cfgio_mod, only: cfg_t, parse_cfg

implicit none

type(cfg_t):: cfg

integer N,i,j,p,iargc,numb
real (kind = 8) Lx,Ly,Lz,Vxmax,Vymax,Vzmax,tmin,tmax,dt,svx,svy,svz,fx,fy,fz,scl,KE,Temp,t,xdiff,ydiff,zdiff,r,k,tau
real (kind = 8), dimension (:), allocatable :: x,y,z,vx,vy,vz,ux,uy,uz,ax,ay,az
integer, parameter :: seed = 99999999
character (len=90) :: filename
character (len=32) :: arg
call srand(seed)

numb = iargc()

call getarg(1, arg)

if (numb == 0) then
  arg = "input.ini"
  write(*,*) "No input file provided. Default input.ini is being used."
endif

cfg = parse_cfg(arg)

call cfg%get("particle","N",N)

allocate(x(N))
allocate(y(N))
allocate(z(N))
allocate(vx(N))
allocate(vy(N))
allocate(vz(N))
allocate(ux(N))
allocate(uy(N))
allocate(uz(N))
allocate(ax(N))
allocate(ay(N))
allocate(az(N))

call cfg%get("temperature","Temp",Temp)

call cfg%get("screening","k",k)

write ( *, '(a,i8)' ) &
    '  The number of processors available = ', omp_get_num_procs ( )
write ( *, '(a,i8)' ) &
    '  The number of threads available    = ', omp_get_max_threads ( )

call cfg%get("length","Lx",Lx)
call cfg%get("length","Ly",Ly)
call cfg%get("length","Lz",Lz)

call cfg%get("time","tmin",tmin)
call cfg%get("time","tmax",tmax)
call cfg%get("time","dt",dt)

Vxmax = 1.0d0
Vymax = 1.0d0
Vzmax = 1.0d0

svx = 0.0d0
svy = 0.0d0
svz = 0.0d0

!=============== Initial Condition ==================

do i = 1,N
  x(i) = (rand())*2.0d0*Lx - Lx
  y(i) = (rand())*2.0d0*Ly - Ly
  z(i) = (rand())*2.0d0*Lz - Lz
  vx(i) = (rand())*Vxmax - Vxmax/2.0d0
  vy(i) = (rand())*Vymax - Vymax/2.0d0
  vz(i) = (rand())*Vzmax - Vzmax/2.0d0
  svx = svx + vx(i)
  svy = svy + vy(i)
  svz = svz + vz(i)
enddo

do i = 1,N
  vx(i) = vx(i) - svx/dfloat(N)
  vy(i) = vy(i) - svy/dfloat(N)
  vz(i) = vz(i) - svz/dfloat(N)
enddo

do i = 1,N
  ax(i) = 0.0d0
  ay(i) = 0.0d0
  az(i) = 0.0d0
    do j = 1,N
      if (i .ne. j) then
        xdiff = ( x(i)-x(j) ) !- nint ((x(i)-x(j))/(2.0d0*Lx)) * 2.0d0*Lx
        ydiff = ( y(i)-y(j) ) !- nint ((y(i)-y(j))/(2.0d0*Ly)) * 2.0d0*Ly
        zdiff = ( z(i)-z(j) ) !- nint ((z(i)-z(j))/(2.0d0*Lz)) * 2.0d0*Lz
        r = dsqrt (xdiff*xdiff + ydiff*ydiff + zdiff*zdiff)
        fx = xdiff*(1.0d0+k*r)*dexp(-k*r)/(r*r*r)
        fy = ydiff*(1.0d0+k*r)*dexp(-k*r)/(r*r*r)
        fz = zdiff*(1.0d0+k*r)*dexp(-k*r)/(r*r*r)
        ax(i) = ax(i) + fx
        ay(i) = ay(i) + fy
        az(i) = az(i) + fz
      endif
    enddo
enddo

!=============== Time Loop =======================

do t = tmin+dt, tmax, dt

KE = 0.0d0
  !$OMP PARALLEL SHARED(Lx,Ly,Lz,x,y,z,ux,uy,uz,vx,vy,vz,N,dt,ax,ay,az,k) PRIVATE (i,j,fx,fy,fz,xdiff,ydiff,zdiff,r)
  !$OMP DO
  do i = 1,N
    ux(i) = vx(i) + ax(i) * dt / 2.0d0
    uy(i) = vy(i) + ay(i) * dt / 2.0d0
    uz(i) = vz(i) + az(i) * dt / 2.0d0
    x(i) = x(i) + ux(i) * dt
    y(i) = y(i) + uy(i) * dt
    z(i) = z(i) + uz(i) * dt
    !x(i) = x(i) - (int(x(i)/(Lx)))  * 2.0d0 * Lx      ! Periodic Boundary Condition
    !y(i) = y(i) - (int(y(i)/(Ly))) * 2.0d0 * Ly      ! Periodic Boundary Condition
    !z(i) = z(i) - (int(z(i)/(Lz)))  * 2.0d0 * Lz      ! Periodic Boundary Condition
    !Perfectly Reflecting Boundary Conditions...
    if (x(i) .gt. Lx .or. x(i) .lt. -Lx) then
      x(i) = x(i) - dt*ux(i)
      ux(i) = -ux(i)
    endif

    if (y(i) .gt. Ly .or. y(i) .lt. -Ly) then
      y(i) = y(i) - dt*uy(i)
      uy(i) = -uy(i)
    endif

    if (z(i) .gt. Lz .or. z(i) .lt. -Lz) then
      z(i) = z(i) - dt*uz(i)
      uz(i) = -uz(i)
    endif
  enddo
  !$OMP END DO

  !$OMP DO
  do i = 1,N
    ax(i) = 0.0d0
    ay(i) = 0.0d0
    az(i) = 0.0d0
      do j = 1,N
        if (i .ne. j) then
          xdiff = ( x(i)-x(j) ) !- nint ((x(i)-x(j))/(2.0d0*Lx)) * 2.0d0*Lx
          ydiff = ( y(i)-y(j) ) !- nint ((y(i)-y(j))/(2.0d0*Ly)) * 2.0d0*Ly
          zdiff = ( z(i)-z(j) ) !- nint ((z(i)-z(j))/(2.0d0*Lz)) * 2.0d0*Lz
          r = dsqrt (xdiff*xdiff + ydiff*ydiff + zdiff*zdiff)
          fx = xdiff*(1.0d0+k*r)*dexp(-k*r)/(r*r*r)
          fy = ydiff*(1.0d0+k*r)*dexp(-k*r)/(r*r*r)
          fz = zdiff*(1.0d0+k*r)*dexp(-k*r)/(r*r*r)
          ax(i) = ax(i) + fx
          ay(i) = ay(i) + fy
          az(i) = az(i) + fz
        endif
      enddo
  enddo
 !$OMP END DO
 !$OMP END PARALLEL

  !$OMP PARALLEL SHARED(p,x,y,z,dt,N,KE) PRIVATE (i,vx,vy,vz)
  !$OMP DO
  do i = 1,N
    vx(i) = ux(i) + ax(i) * dt / 2.0d0
    vy(i) = uy(i) + ay(i) * dt / 2.0d0
    vz(i) = uz(i) + az(i) * dt / 2.0d0
    KE = KE + ( vx(i)*vx(i) + vy(i)*vy(i)  + vz(i)*vz(i)) / 2.0d0
  enddo
  !$OMP END DO

 !$OMP DO
  do i = 1,N
    p = int(t/dt)
    write(filename, '("output/fort.",I8.8)') p+100
    open(unit=p+100,file=filename,status='unknown')
    write(p+100,*) x(i),y(i),z(i)
    ! write (p+100,*) x(i), y(i), z(i)
  enddo
 !$OMP END DO
 !$OMP END PARALLEL
  close (p+100)
  tau = 10.0d0 * dt
  scl = dsqrt (1.0d0 + (dt/tau) * ((Temp/(2.0d0*KE/(3.0d0*dfloat(N)) )) -1.0d0))

  if (t .le. tmax/2.0d0) then
    do i = 1,N
      vx(i) = scl * vx(i)
      vy(i) = scl * vy(i)
      vz(i) = scl * vz(i)
    enddo
  else
    do i = 1,N
      vx(i) = vx(i)
      vy(i) = vy(i)
      vz(i) = vz(i)
    enddo
  endif

enddo     !time

end program molecular_dynamics_3d


      subroutine calc_k(k, nh, fo, ic)
      implicit none
c
      double precision k
      integer nh
      double precision fo(nh), ic(nh)
c
      integer ih
      double precision k_num, k_den
c
      k_num = 0
      k_den = 0
      do ih=1,nh
        k_num = k_num + fo(ih)*sqrt(ic(ih))
        k_den = k_den + ic(ih)
      enddo
      k = k_num/k_den
      end
c
c-----
c
      subroutine calc_w(w, nh, io, so, ic, k, wa, wb)
      implicit none
c
      double precision w(nh)
      integer nh
      double precision io(nh), so(nh), ic(nh), k, wa, wb
c
      integer ih
      double precision k_sq, ik, sk, p, sk_sq, wa_p_sq
c
      k_sq = k**2
      do ih=1,nh
        ik = io(ih)/k_sq
        sk = so(ih)/k_sq
        if (ik .lt. 0) ik = 0
        p = (ik+2*ic(ih))/3
        sk_sq = sk**2
        wa_p_sq = (wa*p)**2
        w(ih) = 1/(sk_sq+wa_p_sq+wb*p)
      enddo
      end
c
c-----
c
      subroutine calc_t(t, nh, io, ic, k, w)
      implicit none
c
      double precision t
      integer nh
      double precision io(nh), ic(nh), k, w(nh)
c
      integer ih
      double precision t_num, t_den, k_sq
c
      k_sq = k**2
      t_num = 0
      t_den = 0
      do ih=1,nh
        t_num = t_num + w(ih)*(io(ih)-k_sq*ic(ih))**2
        t_den = t_den + w(ih)*io(ih)**2
      enddo
      t = t_num / t_den
c
      end
c
c-----
c
      subroutine kwt(t, nh, fo, io, so, ic, wa, wb)
      implicit none
c
      double precision t
      integer nh
      double precision fo(nh), io(nh), so(nh), ic(nh), wa, wb
c
      double precision k
      double precision w(nh)
c
      call calc_k(k, nh, fo, ic)
      call calc_w(w, nh, io, so, ic, k, wa, wb)
      call calc_t(t, nh, io, ic, k, w)
c
      end


C***********************************************************************
C    Module:  autil.f
C
C    Copyright (C) 2002 Mark Drela, Harold Youngren
C
C    This program is free software; you can redistribute it and/or modify
C    it under the terms of the GNU General Public License as published by
C    the Free Software Foundation; either version 2 of the License, or
C    (at your option) any later version.
C
C    This program is distributed in the hope that it will be useful,
C    but WITHOUT ANY WARRANTY; without even the implied warranty of
C    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C    GNU General Public License for more details.
C
C    You should have received a copy of the GNU General Public License
C    along with this program; if not, write to the Free Software
C    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
C***********************************************************************

      SUBROUTINE M3INV(A,AINV)
      DIMENSION A(3,3), AINV(3,3)
C----------------------------------------------
C     Calculates inverse of 3x3 matrix with
C     special treatment...
C
C       If a diagonal element is exactly zero,
C       then it is interpreted as infinity.
C----------------------------------------------
      REAL T(3,6)
C
C---- set augmented matrix
      DO K=1, 3
        T(K,1) = A(K,1)
        T(K,2) = A(K,2)
        T(K,3) = A(K,3)
        T(K,4) = 0.
        T(K,5) = 0.
        T(K,6) = 0.
      ENDDO
      T(1,4) = 1.0
      T(2,5) = 1.0
      T(3,6) = 1.0
C
      DO N=1, 3
        PIVOT = T(N,N)
C
C------ normalize pivot row...
        IF(PIVOT .EQ. 0.0) THEN
C-------- interpret pivot as infinity
          DO L=N+1, 6
            T(N,L) = 0.0
          ENDDO
        ELSE
C-------- interpret pivot as-is
          DO L=N+1, 6
            T(N,L) = T(N,L)/PIVOT
          ENDDO
        ENDIF
C
C------ eliminate pivot column
        DO K=N+1, 3
          TEL = T(K,N)
          DO L=N+1, 6
            T(K,L) = T(K,L) - TEL*T(N,L)
          ENDDO
        ENDDO
      ENDDO
C
C---- back-substitute
      DO N=3, 2, -1
        DO K=N-1, 1, -1
          TEL = T(K,N)
          DO L=4, 6
            T(K,L) = T(K,L) - TEL*T(N,L)
          ENDDO
        ENDDO
      ENDDO
C
      DO K=1, 3
        AINV(K,1) = T(K,4)
        AINV(K,2) = T(K,5)
        AINV(K,3) = T(K,6)
      ENDDO
C
      RETURN
      END ! M3INV

      SUBROUTINE RATEKI3(A, R,R_A)
      DIMENSION A(3)
      DIMENSION R(3,3), R_A(3,3,3)
C-----------------------------------------------------
C                                    t
C     Calculates inverse of tensor  T K
C
C                            t
C     d{phi theta psi}  =  [T K] d{p q r}
C
C-----------------------------------------------------
      C1 = COS(A(1))
      C2 = COS(A(2))
C
      S1 = SIN(A(1))
C
      T2 = TAN(A(2))
C
      R(1,1)     = -1.0
      R(2,1)     = 0.
      R(3,1)     = 0.
C
      R(1,2)     =  S1*T2
      R(2,2)     =  C1
      R(3,2)     =  S1/C2
C
      R(1,3)     = -C1*T2
      R(2,3)     =  S1
      R(3,3)     = -C1/C2
C
      R_A(1,1,1) = 0.
      R_A(2,1,1) = 0.
      R_A(3,1,1) = 0.
C
      R_A(1,2,1) =  C1*T2
      R_A(2,2,1) = -S1
      R_A(3,2,1) =  C1/C2
C
      R_A(1,3,1) =  S1*T2
      R_A(2,3,1) =  C1
      R_A(3,3,1) =  S1/C2
C
      R_A(1,1,2) = 0.
      R_A(2,1,2) = 0.
      R_A(3,1,2) = 0.
C
      R_A(1,2,2) =  S1/C2**2
      R_A(2,2,2) = 0.
      R_A(3,2,2) =  S1*T2/C2
C
      R_A(1,3,2) = -C1/C2**2
      R_A(2,3,2) = 0.
      R_A(3,3,2) = -C1*T2/C2
C
      R_A(1,1,3) = 0.
      R_A(2,1,3) = 0.
      R_A(3,1,3) = 0.
C
      R_A(1,2,3) = 0.
      R_A(2,2,3) = 0.
      R_A(3,2,3) = 0.
C
      R_A(1,3,3) = 0.
      R_A(2,3,3) = 0.
      R_A(3,3,3) = 0.
C
      RETURN
      END ! RATEKI3

      SUBROUTINE ROTENS3(A,T,T_A)
      DIMENSION A(3), T(3,3), T_A(3,3,3)
C------------------------------------------
C     Calculates net rotation tensor T(..)
C     from the three rotation angles A(.).
C
C     The order and sense of rotation from
C     X axes to X' axes is
C
C      X'  =   A3 [ -A2 [ A1 [ X ] ] ]
C
C      X'  =  T X
C------------------------------------------
C
      C1 = COS(A(1))   !  Phi
      C2 = COS(A(2))   !  Theta
      C3 = COS(A(3))   !  Psi
C
      S1 = SIN(A(1))
      S2 = SIN(A(2))
      S3 = SIN(A(3))
C
      T(1,1) =     C2*C3
      T(2,1) =    -C2*S3
      T(3,1) =    -S2
C
      T(1,2) = -S1*S2*C3 + C1*S3
      T(2,2) =  S1*S2*S3 + C1*C3
      T(3,2) = -S1*C2
C
      T(1,3) =  C1*S2*C3 + S1*S3
      T(2,3) = -C1*S2*S3 + S1*C3
      T(3,3) =  C1*C2
C
C
      T_A(1,1,1) = 0.
      T_A(2,1,1) = 0.
      T_A(3,1,1) = 0.
C
      T_A(1,2,1) = -C1*S2*C3 - S1*S3
      T_A(2,2,1) =  C1*S2*S3 - S1*C3
      T_A(3,2,1) = -C1*C2
C
      T_A(1,3,1) = -S1*S2*C3 + C1*S3
      T_A(2,3,1) =  S1*S2*S3 + C1*C3
      T_A(3,3,1) = -S1*C2
C
C
      T_A(1,1,2) =    -S2*C3
      T_A(2,1,2) =     S2*S3
      T_A(3,1,2) =    -C2
C
      T_A(1,2,2) = -S1*C2*C3
      T_A(2,2,2) =  S1*C2*S3
      T_A(3,2,2) =  S1*S2
C
      T_A(1,3,2) =  C1*C2*C3
      T_A(2,3,2) = -C1*C2*S3
      T_A(3,3,2) = -C1*S2
C
C
      T_A(1,1,3) =    -C2*S3
      T_A(2,1,3) =    -C2*C3
      T_A(3,1,3) = 0.
C
      T_A(1,2,3) =  S1*S2*S3 + C1*C3
      T_A(2,2,3) =  S1*S2*C3 - C1*S3
      T_A(3,2,3) = 0.
C
      T_A(1,3,3) = -C1*S2*S3 + S1*C3
      T_A(2,3,3) = -C1*S2*C3 - S1*S3
      T_A(3,3,3) = 0.
C
C
      RETURN
      END ! ROTENS3


! { dg-do run }
! { dg-additional-options "-fdump-tree-original" }
! { dg-require-visibility "" }
!
! Tests the fix for PR64952, in which the assignment to 'array' should
! have generated a temporary because of the references to the lhs in
! the function 'Fred'.
!
! Original report, involving function 'Nick'
! Contributed by Nick Maclaren  <nmm1@cam.ac.uk> on clf
! https://groups.google.com/forum/#!topic/comp.lang.fortran/TvVY5j3GPmg
!
! Other tests are due to Mikael Morin  <mikael.morin@sfr.fr>
!
MODULE M
    INTEGER, PRIVATE :: i
    REAL :: arraym(5) = (/ (i+0.0, i = 1,5) /)
CONTAINS
    ELEMENTAL FUNCTION Bill (n, x)
        REAL :: Bill
        INTEGER, INTENT(IN) :: n
        REAL, INTENT(IN) :: x
        Bill = x+SUM(arraym(:n-1))+SUM(arraym(n+1:))
    END FUNCTION Bill

    ELEMENTAL FUNCTION Charles (x)
        REAL :: Charles
        REAL, INTENT(IN) :: x
        Charles = x
    END FUNCTION Charles
END MODULE M

ELEMENTAL FUNCTION Peter(n, x)
    USE M
    REAL :: Peter
    INTEGER, INTENT(IN) :: n
    REAL, INTENT(IN) :: x
    Peter = Bill(n, x)
END FUNCTION Peter

PROGRAM Main
    use M
    INTEGER :: i, index(5) = (/ (i, i = 1,5) /)
    REAL :: array(5) = (/ (i+0.0, i = 1,5) /)

    INTERFACE
        ELEMENTAL FUNCTION Peter(n, x)
            REAL :: Peter
            INTEGER, INTENT(IN) :: n
            REAL, INTENT(IN) :: x
        END FUNCTION Peter
    END INTERFACE

    PROCEDURE(Robert2), POINTER :: missme => Null()

    ! Original testcase
    array = Nick(index,array)
    If (any (array .ne. array(1))) call abort

    array = (/ (i+0.0, i = 1,5) /)
    ! This should not create a temporary
    array = Charles(array)
    If (any (array .ne. index)) call abort
    ! { dg-final { scan-tree-dump-times "array\\\[\[^\\\]\]*\\\]\\s*=\\s*charles\\s*\\(&array\\\[\[^\\\]\]*\\\]\\);" 1 "original" } }

    ! Check use association of the function works correctly.
    arraym = Bill(index,arraym)
    if (any (arraym .ne. arraym(1))) call abort

    ! Check siblings interact correctly.
    array = (/ (i+0.0, i = 1,5) /)
    array = Henry(index)
    if (any (array .ne. array(1))) call abort

    array = (/ (i+0.0, i = 1,5) /)
    ! This should not create a temporary
    array = index + Henry2(0) - array
    ! { dg-final { scan-tree-dump-times "array\\\[\[^\\\]\]*\\\]\\s*=\\s*\\(\\(real\\(kind=4\\)\\)\\s*index\\\[\[^\\\]\]*\\\]\\s*\\+\\s*D.\\d*\\)\\s*-\\s*array\\\[\[^\\\]\]*\\\];" 1 "original" } }
    if (any (array .ne. 15.0)) call abort

    arraym = (/ (i+0.0, i = 1,5) /)
    arraym = Peter(index, arraym)
    if (any (arraym .ne. 15.0)) call abort

    array = (/ (i+0.0, i = 1,5) /)
    array = Robert(index)
    if (any (arraym .ne. 15.0)) call abort

    missme => Robert2
    array = (/ (i+0.0, i = 1,5) /)
    array = David(index)
    if (any (arraym .ne. 15.0)) call abort

    array = (/ (i+0.0, i = 1,5) /)
    array = James(index)
    if (any (arraym .ne. 15.0)) call abort

    array = (/ (i+0.0, i = 1,5) /)
    array = Romeo(index)
    if (any (arraym .ne. 15.0)) call abort

CONTAINS
    ELEMENTAL FUNCTION Nick (n, x)
        REAL :: Nick
        INTEGER, INTENT(IN) :: n
        REAL, INTENT(IN) :: x
        Nick = x+SUM(array(:n-1))+SUM(array(n+1:))
    END FUNCTION Nick

! Note that the inverse order of Henry and Henry2 is trivial.
! This way round, Henry2 has to be resolved before Henry can
! be marked as having an inherited external array reference.
    ELEMENTAL FUNCTION Henry2 (n)
        REAL :: Henry2
        INTEGER, INTENT(IN) :: n
        Henry2 = n + SUM(array(:n-1))+SUM(array(n+1:))
    END FUNCTION Henry2

    ELEMENTAL FUNCTION Henry (n)
        REAL :: Henry
        INTEGER, INTENT(IN) :: n
        Henry = Henry2(n)
    END FUNCTION Henry

    PURE FUNCTION Robert2(n)
        REAL :: Robert2
        INTEGER, INTENT(IN) :: n
        Robert2 = Henry(n)
    END FUNCTION Robert2

    ELEMENTAL FUNCTION Robert(n)
        REAL :: Robert
        INTEGER, INTENT(IN) :: n
        Robert = Robert2(n)
    END FUNCTION Robert

    ELEMENTAL FUNCTION David (n)
        REAL :: David
        INTEGER, INTENT(IN) :: n
        David = missme(n)
    END FUNCTION David

    ELEMENTAL SUBROUTINE James2 (o, i)
        REAL, INTENT(OUT) :: o
        INTEGER, INTENT(IN) :: i
        o = Henry(i)
    END SUBROUTINE James2

    ELEMENTAL FUNCTION James(n)
        REAL :: James
        INTEGER, INTENT(IN) :: n
        CALL James2(James, n)
    END FUNCTION James

    FUNCTION Romeo2(n)
        REAL :: Romeo2
        INTEGER, INTENT(in) :: n
        Romeo2 = Henry(n)
    END FUNCTION Romeo2

    IMPURE ELEMENTAL FUNCTION Romeo(n)
        REAL :: Romeo
        INTEGER, INTENT(IN) :: n
        Romeo = Romeo2(n)
    END FUNCTION Romeo
END PROGRAM Main


module mod_arrays

  ! Utility functions that operate on arrays.

  implicit none

  private
  public :: denan, mean

contains

  pure function denan(x)
    ! Given input array x, returns an array
    ! of elements that exclude NaNs.
    use ieee_arithmetic, only: ieee_is_nan
    real, allocatable, intent(in) :: x(:)
    real, allocatable :: denan(:)
    denan = pack(x, .not. ieee_is_nan(x))
  end function denan

  pure real function mean(x)
    ! Returns a mean of x.
    real, allocatable, intent(in) :: x(:)
    mean = sum(x) / size(x)
  end function mean

end module mod_arrays


! { dg-do run }
! { dg-options "-fdefault-integer-8" }
! PR fortran/32968
program selected

  if (selected_int_kind (1)  /= 1) call abort
  if (selected_int_kind (3)  /= 2) call abort
  if (selected_int_kind (5)  /= 4) call abort
  if (selected_int_kind (10) /= 8) call abort
  if (selected_real_kind (1)  /= 4) call abort
  if (selected_real_kind (2)  /= 4) call abort
  if (selected_real_kind (9)  /= 8) call abort
  if (selected_real_kind (10) /= 8) call abort

end program selected


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/master/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>  \brief This module contains tests of the module [Matrix_mod](@ref matrix_mod).
!>  @author Amir Shahmoradi

module Test_Matrix_mod

    use Matrix_mod
    use Err_mod, only: Err_type
    use Test_mod, only: Test_type
    implicit none

    private
    public :: test_Matrix

    type(Test_type) :: Test

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    subroutine test_Matrix()

        implicit none

        Test = Test_type(moduleName=MODULE_NAME)
        call Test%run(test_isPosDef_1, "test_isPosDef_1")
        call Test%run(test_isPosDef_2, "test_isPosDef_2")
        call Test%run(test_getInvMat_1, "test_getInvMat_1")
        call Test%run(test_getOuterProd_1, "test_getOuterProd_1")
        call Test%run(test_getInvMatDet_1, "test_getInvMatDet_1")
        call Test%run(test_sortPosDefMat_1, "test_sortPosDefMat_1")
        call Test%run(test_getRegresCoef_1, "test_getRegresCoef_1")
        call Test%run(test_multiplyMatrix_1, "test_multiplyMatrix_1")
        call Test%run(test_getDeterminant_1, "test_getDeterminant_1")
        call Test%run(test_getInvPosDefMat_1, "test_getInvPosDefMat_1")
        call Test%run(test_getInvPosDefMat_2, "test_getInvPosDefMat_2")
        call Test%run(test_getCholeskyFactor_1, "test_getCholeskyFactor_1")
        call Test%run(test_getCholeskyFactor_2, "test_getCholeskyFactor_2")
        call Test%run(test_getInvMatFromCholFac, "test_getInvMatFromCholFac")
        call Test%run(test_getSqrtDetPosDefMat_1, "test_getSqrtDetPosDefMat_1")
        call Test%run(test_getSqrtDetPosDefMat_2, "test_getSqrtDetPosDefMat_2")
        call Test%run(test_getInvPosDefMatSqrtDet_1, "test_getInvPosDefMatSqrtDet_1")
        call Test%run(test_getInvPosDefMatSqrtDet_2, "test_getInvPosDefMatSqrtDet_2")
        call Test%run(test_getLogSqrtDetPosDefMat_1, "test_getLogSqrtDetPosDefMat_1")
        call Test%run(test_getLogSqrtDetPosDefMat_2, "test_getLogSqrtDetPosDefMat_2")
        call Test%run(test_symmetrizeUpperSquareMatrix_1, "test_symmetrizeUpperSquareMatrix_1")
        call Test%finalize()

    end subroutine test_Matrix

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getCholeskyFactor_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none
        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: CholeskyLower_ref(nd,nd) = reshape(  [ 1.000000000000000_RK, 0.000000000000000_RK, 1.000000000000000_RK &
                                                                        , 0.000000000000000_RK, 2.000000000000000_RK, 0.000000000000000_RK &
                                                                        , 1.000000000000000_RK, 0.000000000000000_RK, 3.000000000000000_RK ] &
                                                                        , shape = shape(CholeskyLower_ref) )
        real(RK)    , parameter :: CholeskyDiagonal_ref(nd) = [ 1.000000000000000_RK, 1.414213562373095_RK, 1.414213562373095_RK ]
        real(RK)                :: CholeskyLower(nd,nd), CholeskyDiagonal(nd)
        real(RK), allocatable   :: CholeskyLower_diff(:,:), CholeskyDiagonal_diff(:)
        CholeskyLower = PosDefMat
        call getCholeskyFactor(nd = nd, PosDefMat = CholeskyLower, Diagonal = CholeskyDiagonal)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(CholeskyLower_diff)) deallocate(CholeskyLower_diff); allocate(CholeskyLower_diff, mold = PosDefMat)
        CholeskyLower_diff = abs(PosDefMat - CholeskyLower_ref)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(CholeskyDiagonal_diff)) deallocate(CholeskyDiagonal_diff); allocate(CholeskyDiagonal_diff, mold = CholeskyDiagonal)
        CholeskyDiagonal_diff = abs(CholeskyDiagonal - CholeskyDiagonal_ref)
        assertion = all(CholeskyLower_diff < tolerance) .and. all(CholeskyDiagonal_diff < tolerance)

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyLower_ref  = ", CholeskyLower_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyLower      = ", CholeskyLower
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyLower_diff = ", CholeskyLower_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyDiagonal_ref   = ", CholeskyDiagonal_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyDiagonal       = ", CholeskyDiagonal
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyDiagonal_diff  = ", CholeskyDiagonal_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getCholeskyFactor_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getCholeskyFactor_2() result(assertion)
        use Constants_mod, only: IK, RK
        implicit none
        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, -1._RK &
                                                                , 0._RK, 2._RK, -0._RK &
                                                                , 1._RK, 0._RK, -3._RK ], shape = shape(PosDefMat) )
        real(RK)                :: CholeskyLower(nd,nd), CholeskyDiagonal(nd)
        CholeskyLower = PosDefMat
        call getCholeskyFactor(nd = nd, PosDefMat = CholeskyLower, Diagonal = CholeskyDiagonal)
        assertion = CholeskyDiagonal(1) < 0._RK
        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyLower      = ", CholeskyLower
            write(Test%outputUnit,"(*(g0,:,', '))") "CholeskyDiagonal   = ", CholeskyDiagonal
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP
    end function test_getCholeskyFactor_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getInvPosDefMatSqrtDet_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: MatInvMat_ref(nd,nd) = reshape(  [ 1.500000000000000_RK, 0.000000000000000_RK, -0.50000000000000_RK &
                                                                    , 0.000000000000000_RK, 0.500000000000000_RK, 0.000000000000000_RK &
                                                                    , -0.50000000000000_RK, 0.000000000000000_RK, 0.500000000000000_RK ] &
                                                                    , shape = shape(MatInvMat_ref) )
        real(RK)    , parameter :: CholeskyDiagonal_ref(nd) = [ 1.000000000000000_RK, 1.414213562373095_RK, 1.414213562373095_RK ]
        real(RK)    , parameter :: sqrtDetInvPosDefMat_ref = 0.5_RK
        real(RK)                :: MatInvMat(nd,nd), sqrtDetInvPosDefMat
        real(RK), allocatable   :: MatInvMat_diff(:,:), sqrtDetInvPosDefMat_diff

        MatInvMat = PosDefMat

        call getInvPosDefMatSqrtDet(nd = nd, MatInvMat = MatInvMat, sqrtDetInvPosDefMat = sqrtDetInvPosDefMat)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(MatInvMat_diff)) deallocate(MatInvMat_diff); allocate(MatInvMat_diff, mold = MatInvMat)

        MatInvMat_diff = abs(MatInvMat - MatInvMat_ref)
        sqrtDetInvPosDefMat_diff = abs(sqrtDetInvPosDefMat - sqrtDetInvPosDefMat_ref)

        assertion = all(MatInvMat_diff < tolerance) .and. sqrtDetInvPosDefMat_diff < tolerance

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat_ref  = ", MatInvMat_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat      = ", MatInvMat
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat_diff = ", MatInvMat_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetInvPosDefMat_ref   = ", sqrtDetInvPosDefMat_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetInvPosDefMat_diff  = ", sqrtDetInvPosDefMat
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetInvPosDefMat       = ", sqrtDetInvPosDefMat_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getInvPosDefMatSqrtDet_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getInvPosDefMatSqrtDet_2() result(assertion)
        use Constants_mod, only: IK, RK
        implicit none
        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, -1._RK &
                                                                , 0._RK, 2._RK, -0._RK &
                                                                , 1._RK, 0._RK, -3._RK ], shape = shape(PosDefMat) )
        real(RK)                :: MatInvMat(nd,nd), sqrtDetInvPosDefMat

        MatInvMat = PosDefMat

        call getInvPosDefMatSqrtDet(nd = nd, MatInvMat = MatInvMat, sqrtDetInvPosDefMat = sqrtDetInvPosDefMat)

        assertion = sqrtDetInvPosDefMat < 0._RK

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat              = ", MatInvMat
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetInvPosDefMat    = ", sqrtDetInvPosDefMat
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getInvPosDefMatSqrtDet_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getInvMatFromCholFac() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: CholeskyLower(nd,nd) = reshape(  [ 1.000000000000000_RK, 0.000000000000000_RK, 1.000000000000000_RK &
                                                                    , 0.000000000000000_RK, 2.000000000000000_RK, 0.000000000000000_RK &
                                                                    , 1.000000000000000_RK, 0.000000000000000_RK, 3.000000000000000_RK ] &
                                                                    , shape = shape(CholeskyLower) )
        real(RK)    , parameter :: CholeskyDiagonal(nd) = [ 1.000000000000000_RK, 1.414213562373095_RK, 1.414213562373095_RK ]
        real(RK)    , parameter :: CholeskyDiagonal_ref(nd) = [ 1.000000000000000_RK, 1.414213562373095_RK, 1.414213562373095_RK ]
        real(RK)    , parameter :: InvMatFromCholFac_ref(nd,nd) = reshape(  [ 1.500000000000000_RK, 0.000000000000000_RK, -0.50000000000000_RK &
                                                                            , 0.000000000000000_RK, 0.500000000000000_RK, 0.000000000000000_RK &
                                                                            , -0.50000000000000_RK, 0.000000000000000_RK, 0.500000000000000_RK ] &
                                                                            , shape = shape(InvMatFromCholFac_ref) )
        real(RK)    , parameter :: sqrtDetInvPosDefMat_ref = 0.5_RK
        real(RK)                :: InvMatFromCholFac(nd,nd)
        real(RK), allocatable   :: InvMatFromCholFac_diff(:,:)

        InvMatFromCholFac = getInvMatFromCholFac(nd = nd, CholeskyLower = CholeskyLower, Diagonal = CholeskyDiagonal)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(InvMatFromCholFac_diff)) deallocate(InvMatFromCholFac_diff); allocate(InvMatFromCholFac_diff, mold = InvMatFromCholFac)

        InvMatFromCholFac_diff = abs(InvMatFromCholFac - InvMatFromCholFac_ref)

        assertion = all(InvMatFromCholFac_diff < tolerance)

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "InvMatFromCholFac_ref  = ", InvMatFromCholFac_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "InvMatFromCholFac      = ", InvMatFromCholFac
            write(Test%outputUnit,"(*(g0,:,', '))") "InvMatFromCholFac_diff = ", InvMatFromCholFac_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getInvMatFromCholFac

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getInvPosDefMat_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: MatInvMat_ref(nd,nd) = reshape(  [ 1.500000000000000_RK, 0.000000000000000_RK, -0.50000000000000_RK &
                                                                    , 0.000000000000000_RK, 0.500000000000000_RK, 0.000000000000000_RK &
                                                                    , -0.50000000000000_RK, 0.000000000000000_RK, 0.500000000000000_RK ] &
                                                                    , shape = shape(MatInvMat_ref) )
        real(RK)                :: MatInvMat(nd,nd)
        real(RK), allocatable   :: MatInvMat_diff(:,:)

        MatInvMat = getInvPosDefMat(nd = nd, PosDefMat = PosDefMat)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(MatInvMat_diff)) deallocate(MatInvMat_diff); allocate(MatInvMat_diff, mold = MatInvMat)
        MatInvMat_diff = abs(MatInvMat - MatInvMat_ref)

        assertion = all(MatInvMat_diff < tolerance)

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat_ref  = ", MatInvMat_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat      = ", MatInvMat
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat_diff = ", MatInvMat_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getInvPosDefMat_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getInvPosDefMat_2() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, -1._RK &
                                                                , 0._RK, 2._RK, -0._RK &
                                                                , 1._RK, 0._RK, -3._RK ], shape = shape(PosDefMat) )
        real(RK)                :: MatInvMat(nd,nd)

        MatInvMat = getInvPosDefMat(nd = nd, PosDefMat = PosDefMat)

        assertion = MatInvMat(1,1) < 0._RK

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat      = ", MatInvMat
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getInvPosDefMat_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getInvMatDet_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: MatInvMat_ref(nd,nd) = reshape(  [ 1.500000000000000_RK, 0.000000000000000_RK, -0.50000000000000_RK &
                                                                    , 0.000000000000000_RK, 0.500000000000000_RK, 0.000000000000000_RK &
                                                                    , -0.50000000000000_RK, 0.000000000000000_RK, 0.500000000000000_RK ] &
                                                                    , shape = shape(MatInvMat_ref) )
        real(RK)    , parameter :: MatrixLU_ref(nd,nd)  = reshape(  [ 1.000000000000000_RK, 0.000000000000000_RK, 1.000000000000000_RK &
                                                                    , 0.000000000000000_RK, 2.000000000000000_RK, 0.000000000000000_RK &
                                                                    , 1.000000000000000_RK, 0.000000000000000_RK, 2.000000000000000_RK ] &
                                                                    , shape = shape(MatInvMat_ref) )
        real(RK)    , parameter :: detInvMat_ref = 0.25_RK
        real(RK)                :: MatInvMat(nd,nd), detInvMat, detInvMat_diff
        real(RK), allocatable   :: MatrixLU(:,:), MatInvMat_diff(:,:), MatrixLU_diff(:,:)

        MatrixLU = PosDefMat

        call getInvMatDet(nd = nd, MatrixLU = MatrixLU, InverseMatrix = MatInvMat, detInvMat = detInvMat)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(MatrixLU_diff)) deallocate(MatrixLU_diff); allocate(MatrixLU_diff, mold = MatrixLU)
        MatrixLU_diff = abs(MatrixLU - MatrixLU_ref)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(MatInvMat_diff)) deallocate(MatInvMat_diff); allocate(MatInvMat_diff, mold = MatInvMat)
        MatInvMat_diff = abs(MatInvMat - MatInvMat_ref)

        detInvMat_diff = abs(detInvMat - detInvMat_ref)

        assertion = all(MatInvMat_diff < tolerance) .and. detInvMat_diff < tolerance

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "MatrixLU_ref  = ", MatrixLU_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "MatrixLU      = ", MatrixLU
            write(Test%outputUnit,"(*(g0,:,', '))") "MatrixLU_diff = ", MatrixLU_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat_ref  = ", MatInvMat_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat      = ", MatInvMat
            write(Test%outputUnit,"(*(g0,:,', '))") "MatInvMat_diff = ", MatInvMat_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "detInvMat_ref  = ", detInvMat_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "detInvMat      = ", detInvMat
            write(Test%outputUnit,"(*(g0,:,', '))") "detInvMat_diff = ", detInvMat_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getInvMatDet_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getInvMat_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: InverseMatrix_ref(nd,nd) = reshape(  [ 1.500000000000000_RK, 0.000000000000000_RK, -0.50000000000000_RK &
                                                                        , 0.000000000000000_RK, 0.500000000000000_RK, 0.000000000000000_RK &
                                                                        , -0.50000000000000_RK, 0.000000000000000_RK, 0.500000000000000_RK ] &
                                                                        , shape = shape(InverseMatrix_ref) )
        real(RK)                :: InverseMatrix(nd,nd)
        real(RK), allocatable   :: InverseMatrix_diff(:,:)

        InverseMatrix = getInvMat(nd = nd, Matrix = PosDefMat)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(InverseMatrix_diff)) deallocate(InverseMatrix_diff); allocate(InverseMatrix_diff, mold = InverseMatrix)

        InverseMatrix_diff = abs(InverseMatrix - InverseMatrix_ref)

        assertion = all(InverseMatrix_diff < tolerance)

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "InverseMatrix_ref  = ", InverseMatrix_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "InverseMatrix      = ", InverseMatrix
            write(Test%outputUnit,"(*(g0,:,', '))") "InverseMatrix_diff = ", InverseMatrix_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getInvMat_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_multiplyMatrix_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)                :: MatrixProduct(nd,nd)
        real(RK), allocatable   :: MatrixProduct_diff(:,:), MatrixProduct_ref(:,:)

        MatrixProduct_ref = matmul(PosDefMat,PosDefMat)

        call multiplyMatrix(A = PosDefMat, rowsA = nd, colsA = nd, B = PosDefMat, rowsB = nd, colsB = nd, C = MatrixProduct)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(MatrixProduct_diff)) deallocate(MatrixProduct_diff); allocate(MatrixProduct_diff, mold = MatrixProduct)

        MatrixProduct_diff = abs(MatrixProduct - MatrixProduct_ref)

        assertion = all(MatrixProduct_diff < tolerance)

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "MatrixProduct_ref  = ", MatrixProduct_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "MatrixProduct      = ", MatrixProduct
            write(Test%outputUnit,"(*(g0,:,', '))") "MatrixProduct_diff = ", MatrixProduct_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_multiplyMatrix_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getDeterminant_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ -1._RK, -0._RK, -1._RK &
                                                                , -0._RK, -2._RK, -0._RK &
                                                                , -1._RK, -0._RK, -3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: determinant_ref = -4._RK
        real(RK)                :: determinant, determinant_diff

        determinant = getDeterminant(nd = nd, Matrix = PosDefMat)

        determinant_diff = abs(determinant - determinant_ref)

        assertion = determinant_diff < tolerance

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "determinant_ref  = ", determinant_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "determinant      = ", determinant
            write(Test%outputUnit,"(*(g0,:,', '))") "determinant_diff = ", determinant_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getDeterminant_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getSqrtDetPosDefMat_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: sqrtDetPosDefMat_ref = 2._RK
        real(RK)                :: sqrtDetPosDefMat, sqrtDetPosDefMat_diff

        sqrtDetPosDefMat = getSqrtDetPosDefMat(nd = nd, PosDefMat = PosDefMat)

        sqrtDetPosDefMat_diff = abs(sqrtDetPosDefMat - sqrtDetPosDefMat_ref)

        assertion = sqrtDetPosDefMat_diff < tolerance

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetPosDefMat_ref  = ", sqrtDetPosDefMat_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetPosDefMat      = ", sqrtDetPosDefMat
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetPosDefMat_diff = ", sqrtDetPosDefMat_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getSqrtDetPosDefMat_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getSqrtDetPosDefMat_2() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ -1._RK, -0._RK, -1._RK &
                                                                , -0._RK, -2._RK, -0._RK &
                                                                , -1._RK, -0._RK, -3._RK ], shape = shape(PosDefMat) )
        real(RK)                :: sqrtDetPosDefMat

        sqrtDetPosDefMat = getSqrtDetPosDefMat(nd = nd, PosDefMat = PosDefMat)

        assertion = sqrtDetPosDefMat < 0._RK

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "sqrtDetPosDefMat      = ", sqrtDetPosDefMat
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getSqrtDetPosDefMat_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getLogSqrtDetPosDefMat_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: logSqrtDetPosDefMat_ref = log(2._RK)
        real(RK)                :: logSqrtDetPosDefMat, logSqrtDetPosDefMat_diff
        real(RK), allocatable   :: Matrix(:,:)
        logical                 :: failed

        Matrix = PosDefMat

        call getLogSqrtDetPosDefMat(nd = nd, PosDefMat = Matrix, logSqrtDetPosDefMat = logSqrtDetPosDefMat, failed = failed)

        assertion = .not. failed
        if (.not. assertion) return

        logSqrtDetPosDefMat_diff = abs(logSqrtDetPosDefMat - logSqrtDetPosDefMat_ref)

        assertion = logSqrtDetPosDefMat_diff < tolerance

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "logSqrtDetPosDefMat_ref  = ", logSqrtDetPosDefMat_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "logSqrtDetPosDefMat      = ", logSqrtDetPosDefMat
            write(Test%outputUnit,"(*(g0,:,', '))") "logSqrtDetPosDefMat_diff = ", logSqrtDetPosDefMat_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getLogSqrtDetPosDefMat_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getLogSqrtDetPosDefMat_2() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )
        real(RK)    , parameter :: logSqrtDetPosDefMat_ref = log(2._RK)
        real(RK)                :: logSqrtDetPosDefMat
        real(RK), allocatable   :: Matrix(:,:)
        logical                 :: failed

        Matrix = -PosDefMat

        call getLogSqrtDetPosDefMat(nd = nd, PosDefMat = Matrix, logSqrtDetPosDefMat = logSqrtDetPosDefMat, failed = failed)

        assertion = failed
        if (.not. assertion) return

    end function test_getLogSqrtDetPosDefMat_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_isPosDef_1() result(assertion)
        use Constants_mod, only: IK, RK
        implicit none
        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ 1._RK, 0._RK, 1._RK &
                                                                , 0._RK, 2._RK, 0._RK &
                                                                , 1._RK, 0._RK, 3._RK ], shape = shape(PosDefMat) )

        assertion = isPosDef(nd = nd, Matrix = PosDefMat)
    end function test_isPosDef_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_isPosDef_2() result(assertion)
        use Constants_mod, only: IK, RK
        implicit none
        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: PosDefMat(nd,nd) = reshape(  [ -1._RK, -0._RK, -1._RK &
                                                                , -0._RK, -2._RK, -0._RK &
                                                                , -1._RK, -0._RK, -3._RK ], shape = shape(PosDefMat) )

        assertion = .not. isPosDef(nd = nd, Matrix = PosDefMat)
    end function test_isPosDef_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_symmetrizeUpperSquareMatrix_1() result(assertion)
        use Constants_mod, only: IK, RK
        implicit none
        logical                 :: assertion
        integer(IK) , parameter :: nd = 3_IK
        real(RK)    , parameter :: UpperSquareMatrix_ref(nd,nd) = reshape(  [ -1._RK, -0._RK, -1._RK &
                                                                            , -0._RK, -2._RK, -0._RK &
                                                                            , -1._RK, -0._RK, -3._RK ], shape = shape(UpperSquareMatrix_ref) )
        real(RK)                :: UpperSquareMatrix(nd,nd)
        integer(IK)             :: i, j

        UpperSquareMatrix = 0._RK
        do j = 1, nd
            do i = 1, j
                UpperSquareMatrix(i,j) = UpperSquareMatrix_ref(i,j)
            end do
        end do

        call symmetrizeUpperSquareMatrix(nd,UpperSquareMatrix)
        assertion = all( abs(UpperSquareMatrix-UpperSquareMatrix_ref) < 1.e-14_RK )

        if (Test%isDebugMode .and. .not. assertion) then
        ! LCOV_EXCL_START
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "UpperSquareMatrix_ref  = ", UpperSquareMatrix_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "UpperSquareMatrix      = ", UpperSquareMatrix
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_symmetrizeUpperSquareMatrix_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getOuterProd_1() result(assertion)

        use Constants_mod, only: IK, RK
        implicit none

        logical                 :: assertion
        real(RK)    , parameter :: tolerance = 1.e-12_RK
        real(RK)    , parameter :: Vector2(*) = [4._RK, 5._RK]
        real(RK)    , parameter :: Vector1(*) = [1._RK, 2._RK, 3._RK]
        real(RK)    , parameter :: OuterProduct_ref(3,2) = reshape( [ 4._RK,  8._RK, 12._RK &
                                                                    , 5._RK, 10._RK, 15._RK ], shape = shape(OuterProduct_ref) )
        real(RK), allocatable   :: OuterProduct(:,:), OuterProduct_diff(:,:)

        OuterProduct = getOuterProd(Vector1 = Vector1, Vector2 = Vector2)

        ! Gfortran 7.1 fails to automatically reallocate this array. This is not implemented in Gfortran 7.0.0
        if (allocated(OuterProduct_diff)) deallocate(OuterProduct_diff); allocate(OuterProduct_diff, mold = OuterProduct)

        OuterProduct_diff = abs(OuterProduct - OuterProduct_ref)

        assertion = all(OuterProduct_diff < tolerance)

        if (Test%isDebugMode .and. .not. assertion) then
        ! LCOV_EXCL_START
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "OuterProduct_ref  = ", OuterProduct_ref
            write(Test%outputUnit,"(*(g0,:,', '))") "OuterProduct      = ", OuterProduct
            write(Test%outputUnit,"(*(g0,:,', '))") "OuterProduct_diff = ", OuterProduct_diff
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        ! LCOV_EXCL_STOP

    end function test_getOuterProd_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_sortPosDefMat_1() result(assertion)

        use Constants_mod, only: RK, IK

        implicit none
        logical(IK)             :: assertion
        integer(IK), parameter  :: ColIndx(*) = [4]
        integer(IK), parameter  :: ColIndxMap(*) = [5]
        integer(IK)             :: rank
        real(RK), allocatable   :: PosDefMat(:,:), OutPosDefMat(:,:), OutPosDefMat_ref(:,:)
        integer(IK)             :: i, j

        assertion = .true.

        rank = 5
        allocate(PosDefMat(rank,rank))
        do j = 1,rank
            do i = 1,j
                PosDefMat(i,j) = i*10 + j
            end do
        end do

        ! switch the variable 4 with 5, such that the output remains a positive-definite matrix.

        OutPosDefMat = sortPosDefMat(rank, PosDefMat, 1_IK, ColIndx, ColIndxMap)

        OutPosDefMat_ref = reshape(  [ 11._RK, 12._RK, 13._RK, 15._RK, 14._RK &
                                    ,  0._RK, 22._RK, 23._RK, 25._RK, 24._RK &
                                    ,  0._RK,  0._RK, 33._RK, 35._RK, 34._RK &
                                    ,  0._RK,  0._RK,  0._RK, 55._RK, 45._RK &
                                    ,  0._RK,  0._RK,  0._RK,  0._RK, 44._RK ] &
                                    , shape = [rank,rank] )
        OutPosDefMat_ref = transpose(OutPosDefMat_ref)
        do j = 1, rank
            do i = 1, j
                assertion = assertion .and. OutPosDefMat_ref(i,j) == OutPosDefMat(i,j)
            end do
        end do

        if (Test%isDebugMode .and. .not. assertion) then
        ! LCOV_EXCL_START

            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "OutPosDefMat_ref:"
            do i = 1,rank
                write(Test%outputUnit,"(*(F7.1))") (OutPosDefMat_ref(i,j),j=1,rank)
            end do
            write(Test%outputUnit,"(*(g0))")

            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "Output Positive-Definite Matrix with variables 4 and 5 swapped:"
            do i = 1,rank
                write(Test%outputUnit,"(*(F7.1))") (OutPosDefMat(i,j),j=1,rank)
            end do
            write(Test%outputUnit,"(*(g0))")

            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "Original Matrix:"
            do i = 1,rank
                write(Test%outputUnit,"(*(F7.1))") (PosDefMat(i,j),j=1,rank)
            end do

        end if
        ! LCOV_EXCL_STOP

    end function test_sortPosDefMat_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_getRegresCoef_1() result(assertion)

        use Constants_mod, only: RK, IK

        implicit none
        logical                 ::  assertion
        real(RK)                ::  normalizedDifference
        integer , parameter     ::  rankPDM = 4, rankS11 = 3, rankS22 = 1
        real(RK), parameter     ::  PosDefMat(rankPDM,rankPDM) = reshape( &
                                    [ 4.414182620515998_RK, 1.173760167060120_RK, 0.757607629189287_RK, 5.075277296976230_RK &
                                    , 1.173760167060120_RK, 0.866956750091570_RK, 0.310654936099342_RK, 1.621274787164182_RK &
                                    , 0.757607629189287_RK, 0.310654936099342_RK, 0.955157221699132_RK, 1.254186231887444_RK &
                                    , 5.075277296976230_RK, 1.621274787164182_RK, 1.254186231887444_RK, 6.407791808961157_RK ] &
                                    , shape=shape(PosDefMat) )
        real(RK), parameter     ::  RegresCoefMatRef(rankS11,rankS22) = reshape( &
                                    [ 0.792047783119072 &
                                    , 0.253016145889269 &
                                    , 0.195728305363088 ] &
                                    , shape=shape(RegresCoefMatRef) )
        real(RK), parameter     ::  SchurComplementRef(rankS11,rankS11) = reshape( &
                                    [ 0.3943204887314210_RK, -0.110366933940115_RK, -0.235767795395625_RK &
                                    , -0.110366933940115_RK,  0.456748052015843_RK, -0.006674430520204_RK &
                                    , -0.235767795395625_RK, -0.006674430520204_RK,  0.709677475922085_RK ] &
                                    , shape=shape(SchurComplementRef) )
        real(RK)                ::  SchurComplement(rankS11,rankS11)
        real(RK)                ::  RegresCoefMat(rankS11,rankS22)
        integer                 ::  i,j

        assertion = .true.

        call getRegresCoef  ( rankPDM           = rankPDM           &
                            , rankS11           = rankS11           &
                            , rankS22           = rankS22           &
                            , PosDefMat         = PosDefMat         &
                            , RegresCoefMat     = RegresCoefMat     &
                            , SchurComplement   = SchurComplement   &
                            )

        do i = 1,rankS11
            !write(Test%outputUnit,"(*(F22.15))") (RegresCoefMat(i,j),j=1,rankS22), (RegresCoefMatRef(i,j),j=1,rankS22)
            do j = 1,rankS22
                normalizedDifference = abs(RegresCoefMatRef(i,j) - RegresCoefMat(i,j)) / (RegresCoefMatRef(i,j) + RegresCoefMat(i,j))
                assertion = assertion .and. normalizedDifference < 1.e-5_RK
            end do
        end do

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "Original Covariance Matrix:"
            do i = 1,rankPDM
                write(Test%outputUnit,"(*(F22.15))") (PosDefMat(i,j),j=1,rankPDM)
            end do
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "RegresCoefMat, RegresCoefMatRef, difference, normalizedDifference:"
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "SchurComplement, SchurComplementRef, difference, normalizedDifference:"
            write(Test%outputUnit,"(*(g0))")
            do i = 1,rankS11
                do j = 1,rankS22
                    write(Test%outputUnit,"(*(F22.15))" ) RegresCoefMat(i,j) &
                                                        , RegresCoefMatRef(i,j) &
                                                        , abs(RegresCoefMat(i,j)-RegresCoefMatRef(i,j)) &
                                                        , normalizedDifference
                end do
            end do
            write(Test%outputUnit,"(*(g0))")
        end if
        ! LCOV_EXCL_STOP

        do i = 1,rankS11
            do j = 1,rankS11
                normalizedDifference = abs(SchurComplementRef(i,j) - SchurComplement(i,j)) / (SchurComplementRef(i,j) + SchurComplement(i,j))
                assertion = assertion .and. normalizedDifference < 1.e-6_RK
            end do
        end do

        ! LCOV_EXCL_START
        if (Test%isDebugMode .and. .not. assertion) then
            do i = 1,rankS11
                do j = 1,rankS11
                    write(Test%outputUnit,"(*(F22.15))" ) SchurComplement(i,j) &
                                                        , SchurComplementRef(i,j) &
                                                        , abs(SchurComplement(i,j)-SchurComplementRef(i,j)) &
                                                        , normalizedDifference
                end do
            end do
        end if
        ! LCOV_EXCL_STOP

    end function test_getRegresCoef_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module Test_Matrix_mod ! LCOV_EXCL_LINE


        program main

        use lcg

        implicit none

        real(8)    :: r
        integer(8) :: s
        integer(4) :: k

        write(*,*) 'TEST'

        call initialize_prng()

        s = seed()
        write(*,*) 'I = ', s

        k = 0
        do while (k < 99)
            r = prn()
            s = seed()
            write(*,*) 's = ', k, s
            k = k + 1
        end do

        call prn_skip(-77_8)
        s = seed()
        r = prn()
        write(*,*) 'S = ', s, r
        end program main


!gfortran cudaonly.f90 -o3 -i$cula_root/include -l$cula_root/lib64 -lcula -lcula_fortran -lcublas -lcudart -o nrfcuda

module lnumz
    integer, parameter:: b4 = selected_real_kind(4)
end module
module pmatrix
interface print_matrix
      subroutine print_matrixc( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*) desc
      integer m, n, lda
      complex(b4) a( lda, * )
      end subroutine print_matrixc
      subroutine print_matrixr( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*) desc
      integer m, n, lda
      real(b4) a( lda, * )
      end subroutine print_matrixr
end interface
end module

program bonk
  use lnumz
  use pmatrix
  complex (b4) a(4,4),b(4,2)
  integer indx(4)
  integer nrhs,lda,ldb,info
  external cula_initialize
  external cula_shutdown

  integer cula_initialize
  integer cula_cgesv

  data  a/ &
      ( 1.23,-5.50),(-2.14,-1.12),(-4.30,-7.10),( 1.27, 7.29), &
      ( 7.91,-5.38),(-9.92,-0.79),(-6.47, 2.52),( 8.90, 6.92), &
      (-9.80,-4.86),(-9.18,-1.12),(-6.51,-2.67),(-8.82, 1.25), &
      (-7.32, 7.57),( 1.37, 0.43),(-5.86, 7.38),( 5.41, 5.37)  /
  data  b/ &
      ( 8.33,-7.32),(-6.18,-4.80),(-5.71,-2.80),(-1.60, 3.08), &
      (-6.11,-3.81),( 0.14,-7.71),( 1.41, 3.40),( 8.54,-4.05)  /
  n=4
  np=4
  nrhs=2
  lda=4
  ldb=4
! the next line is the mkl/lapack call to solve this system
!  call cgesv( n, nrhs, a, lda, indx, b, ldb, info )
         write(*,*) 'initializing cula'
         status = cula_initialize()
         call check_status(status)

         write(*,*) 'calling cula_cgesv'
!                         (int n, int nrhs, culafloatcomplex* a,
!                          int lda, culaint* ipiv, culafloatcomplex* b,
!                          int ldb);
         status=cula_cgesv( n, nrhs, a,  lda, indx, b,ldb)
!         call cgesv( n, nrhs, a, lda, indx, b, ldb, info )
         call check_status(status)

         write(*,*) 'shutting down cula'
         call cula_shutdown()
  call print_matrix( "details of lu factorization", 4, 4, a, lda )
  call print_matrix( "solution", 4, 2, b, ldb )
end program

! solution
! ( -1.09, -0.18) (  1.28,  1.21)
! (  0.97,  0.52) ( -0.22, -0.97)
! ( -0.20,  0.19) (  0.53,  1.36)
! ( -0.59,  0.92) (  2.22, -1.00)
!
! details of lu factorization
! ( -4.30, -7.10) ( -6.47,  2.52) ( -6.51, -2.67) ( -5.86,  7.38)
! (  0.49,  0.47) ( 12.26, -3.57) ( -7.87, -0.49) ( -0.98,  6.71)
! (  0.25, -0.15) ( -0.60, -0.37) (-11.70, -4.64) ( -1.35,  1.38)
! ( -0.83, -0.32) (  0.05,  0.58) (  0.93, -0.50) (  2.66,  7.86)

      subroutine print_matrixc( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*)    desc
      integer          m, n, lda
      complex(b4)          a( lda, * )
!
      integer          i, j
!
      write(*,*)
      write(*,*) desc
      do i = 1, m
         write(*,9998) ( a( i, j ), j = 1, n )
      end do
!
 9998 format( 11(:,1x,'(',f6.2,',',f6.2,')') )
      return
      end subroutine

      subroutine print_matrixr( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*)    desc
      integer          m, n, lda
      real(b4)          a( lda, * )
!
      integer          i, j
!
      write(*,*)
      write(*,*) desc
      do i = 1, m
         write(*,9998) ( a( i, j ), j = 1, n )
      end do
!
 9998 format( 22(:,1x,f6.2) )
      return
      end subroutine
      subroutine check_status(status)
         integer status
         integer info
         integer cula_geterrorinfo

         if (status .ne. 0) then
            if (status .eq. 6) then
!              culaargumenterror
               info = cula_geterrorinfo()
               write(*,*) 'invalid value for parameter ', info
            else if (status .eq. 9) then
!              cularuntimeerror
               info = cula_geterrorinfo()
               write(*,*) 'runtime error (', info ,')'
            else
!              others
               call cula_getstatusstring(status)
            endif
            stop 1
         end if
      end


program gemv_omp

USE OMP_LIB

implicit none
integer,parameter:: N=64
real(8),allocatable :: A(:,:),V(:,:),Vout(:,:)
real(8) :: alpha=1.0
integer :: ti,tj,tk
integer :: err
integer :: i,val
integer,parameter :: Num_calc=8

!!starts here
call system_clock(ti,tk)

allocate(A(1:N*N,1:Num_calc),stat=err)
if(err/=0) print'(a30,i9,i3)', 'ERROR in allocation for A',err
allocate(V(1:N,1:Num_calc),stat=err)
if(err/=0) print'(a30,i9,i3)', 'ERROR in allocation for V',err
allocate(Vout(1:N,1:Num_calc),stat=err)
if(err/=0) print'(a30,i9,i3)', 'ERROR in allocation for Vout',err

!$omp parallel do
do i=1,Num_calc
   A(:,i) = 1.0
   V(:,i) = 1.0
   call gemv(N,alpha,A(:,i),V(:,i),Vout(:,i))
end do
!$omp end parallel do

do i=1,Num_calc
!$omp target update from(Vout(:,i))
   do val=1,N
     if (int(Vout(val,i)) .NE. N) then
        write(*,*) "Value does not match at",val,i,int(Vout(val,i))
     end if
   end do
end do

deallocate(A)
if(err/=0) print'(a30,i9,i3)', 'ERROR in deallocation for A',err
deallocate(V)
if(err/=0) print'(a30,i9,i3)', 'ERROR in deallocation for V',err
deallocate(Vout)
if(err/=0) print'(a30,i9,i3)', 'ERROR in deallocation for Vout',err
call system_clock(tj,tk)

print'(a20,3x,f12.4)',"total time: ", dble(tj-ti)/dble(tk)

stop
end

!-------------------------------------------------------
subroutine gemv(nval,alpha,A,V,Vout)

USE OMP_LIB
implicit none

integer:: row,col,A_row
integer:: nval,tid
real(8) :: alpha,sum_val
real(8),intent(in) :: A(1:nval*nval),V(1:nval)
real(8),intent(out):: Vout(1:nval)

!$omp target teams distribute map(to:A,V) map(from:Vout)
do row=1,nval
   sum_val = 0.0
   A_row =(row-1)*nval
   do col=1,nval
      sum_val = sum_val + A(A_row+col)*V(col)
   end do
   Vout(row) = sum_val * alpha
end do
!$omp end target teams distribute
end subroutine


!==========================================================================
elemental function gsw_sigma4 (sa, ct)
!==========================================================================
!
!  Calculates potential density anomaly with reference pressure of 4000 dbar,
!  this being this particular potential density minus 1000 kg/m^3.  This
!  function has inputs of Absolute Salinity and Conservative Temperature.
!
! sa     : Absolute Salinity                               [g/kg]
! ct     : Conservative Temperature                        [deg C]
!
! gsw_sigma4  : potential density anomaly with reference pressure of 4000
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_rho

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct

real (r8) :: gsw_sigma4

gsw_sigma4 = gsw_rho(sa,ct,4e3_r8) - 1e3_r8

return
end function

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