	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Schrodinger equation in 2 dimensions
	! i*u_t+Es*|u|^2u+u_{xx}+u_{yy}=0
	! using a second order time spectral splitting scheme
	!
	! The boundary conditions are u(x=0,y)=u(2*Lx*\pi,y),
	!	u(x,y=0)=u(x,y=2*Ly*\pi)
	! The initial condition is u=exp(-x^2-y^2)
	!
	! AUTHORS
	!
	! B. Cloutier, B.K. Muite, P. Rigge
	! 4 June 2012
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  numthreads		= number of openmp threads
	!  ierr				= error return code
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfxy			= Forward 2d fft plan
	!  planbxy			= Backward 2d fft plan
	!  dt				= timestep
	!  InMass			= initial mass
	!  FiMass			= final mass
	!  InEner			= initial energy
	!  FiEner			= final energy
	! .. Arrays ..
	!  u				= approximate solution
	!  v				= Fourier transform of approximate solution
	!  temp1 			= temporary field
	!  temp2 			= temporary field
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  x				= x locations
	!  y				= y locations
	!  time				= times at which save data
	!  name_config		= array to store filename for data to be saved
	!
	! REFERENCES
	!
	! This program is based on example code to demonstrate usage of Fortran and
	! CUDA FFT routines taken from
	! http://cudamusing.blogspot.com/2010/05/CALLing-cufft-from-cuda-fortran.html
	!
	! and
	!
	! http://cudamusing.blogspot.com/search?q=cublas
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	! precision
	! cufft
	!
	! External libraries required
	! CuFFT	 -- Cuda FFT Library
	! OpenACC

	!
	! Define the INTERFACE to the NVIDIA CUFFT routines
	!

	module precision
	! Precision control

	integer, parameter, public :: Single = kind(0.0) ! Single precision
	integer, parameter, public :: Double = kind(0.0d0) ! Double precision

	integer, parameter, public :: fp_kind = Double
	!integer, parameter, public :: fp_kind = Single

	end module precision

	module cufft

	integer, public :: CUFFT_FORWARD = -1
	integer, public :: CUFFT_INVERSE = 1
	integer, public :: CUFFT_R2C = Z'2a' ! Real to Complex (interleaved)
	integer, public :: CUFFT_C2R = Z'2c' ! Complex (interleaved) to Real
	integer, public :: CUFFT_C2C = Z'29' ! Complex to Complex, interleaved
	integer, public :: CUFFT_D2Z = Z'6a' ! Double to Double-Complex
	integer, public :: CUFFT_Z2D = Z'6c' ! Double-Complex to Double
	integer, public :: CUFFT_Z2Z = Z'69' ! Double-Complex to Double-Complex

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! cufftPlan2d(cufftHandle *plan, int nx,int ny, cufftType type)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	interface cufftPlan2d
	subroutine cufftPlan2d(plan, nx, ny, type) bind(C,name='cufftPlan2d')
	use iso_c_binding
	integer(c_int):: plan
	integer(c_int),value:: nx, ny, type
	end subroutine cufftPlan2d
	end interface cufftPlan2d

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! cufftDestroy(cufftHandle plan)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	interface cufftDestroy
	subroutine cufftDestroy(plan) bind(C,name='cufftDestroy')
	use iso_c_binding
	integer(c_int),value:: plan
	end subroutine cufftDestroy
	end interface cufftDestroy

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! cufftExecZ2Z(cufftHandle plan,
	! cufftDoubleComplex *idata,
	! cufftDoubleComplex *odata,
	! int direction;
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	interface cufftExecZ2Z
	subroutine cufftExecZ2Z(plan, idata, odata, direction) &
	& bind(C,name='cufftExecZ2Z')
	use iso_c_binding
	use precision
	integer(c_int),value:: direction
	integer(c_int),value:: plan
	complex(fp_kind),device,dimension(1:nx,1:ny):: idata,odata
	end subroutine cufftExecZ2Z
	end interface cufftExecZ2Z
	end module cufft

	PROGRAM main
	USE precision
	USE cufft
	USE openacc

	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4), PARAMETER 	::  Nx=128
	INTEGER(kind=4), PARAMETER 	::  Ny=128
	INTEGER(kind=4), PARAMETER	::  Nt=20
	INTEGER(kind=4), PARAMETER	::  plotgap=20
	REAL(fp_kind), PARAMETER		::  &
	pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(fp_kind), PARAMETER		::  Lx=5.0d0
	REAL(fp_kind), PARAMETER		::  Ly=5.0d0
	REAL(fp_kind), PARAMETER		::  Es=1.0d0
	REAL(fp_kind)					::  dt=0.10d0**5
	REAL(fp_kind)					:: scalemodes
	COMPLEX(fp_kind)				:: InMass,FiMass,InEner,FiEner
	COMPLEX(fp_kind), DIMENSION(:), ALLOCATABLE		::  kx
	COMPLEX(fp_kind), DIMENSION(:), ALLOCATABLE		::  ky
	REAL(fp_kind),  	 DIMENSION(:), ALLOCATABLE	::  x
	REAL(fp_kind),  	 DIMENSION(:), ALLOCATABLE	::  y
	COMPLEX(fp_kind), DIMENSION(:,:), ALLOCATABLE	::  u,v,temp1,temp2
	REAL(fp_kind), 	 DIMENSION(:), ALLOCATABLE		::  time
	INTEGER(kind=4)				::  i,j,k,n,allocatestatus,ierr, vecsize,gangsize
	REAL(fp_kind)			 	::  start_time,stop_time
	INTEGER(kind=4)				::  plan
   	CHARACTER*100			 	::  name_config

	vecsize=32
	gangsize=16
	PRINT *,'Program starting'
	PRINT *,'Grid: ',Nx,'X',Ny

	ALLOCATE(kx(1:Nx),ky(1:Nx),x(1:Nx),y(1:Nx),u(1:Nx,1:Ny),&
			v(1:Nx,1:Ny),temp1(1:Nx,1:Ny),temp2(1:Nx,1:Ny),&
			time(1:1+Nt/plotgap),stat=allocatestatus)
	IF (allocatestatus .ne. 0) stop
	PRINT *,'allocated memory'

	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)

	! set up ffts
	CALL cufftPlan2D(plan,nx,ny,CUFFT_Z2Z)
	PRINT *,'Setup FFTs'

	! setup fourier frequencies
	!$acc kernels loop
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	END DO
	!$acc end kernels
	kx(1+Nx/2)=0.0d0
	!$acc kernels loop
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	!$acc end kernels
	!$acc kernels loop
  	DO i=1,Nx
		x(i)=(-1.0d0+2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)) )*pi*Lx
	END DO
	!$acc end kernels
	!$acc kernels loop
	DO j=1,1+Ny/2
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	!$acc end kernels
	ky(1+Ny/2)=0.0d0
	!$acc kernels loop
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
	!$acc end kernels
	!$acc kernels loop
  	DO j=1,Ny
		y(j)=(-1.0d0+2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)) )*pi*Ly
	END DO
	!$acc end kernels
	scalemodes=1.0d0/REAL(Nx*Ny,kind(0d0))
	PRINT *,'Setup grid and fourier frequencies'
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			u(i,j)=exp(-1.0d0*(x(i)**2 +y(j)**2))
		END DO
	END DO
	!$acc end kernels
	! transform initial data
	CALL cufftExecZ2Z(plan,u,v,CUFFT_FORWARD)

	PRINT *,'Got initial data'
	! get initial mass
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp1(i,j)=abs(u(i,j))**2
		END DO
	END DO
	!$acc end kernels
	! Use FFT to get initial mass
	CALL cufftExecZ2Z(plan,temp1,temp2,CUFFT_FORWARD)
	!$acc end data
	InMass=temp2(1,1)
	! Get initial energy
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp1(i,j)=-ES*0.25d0*abs(u(i,j))**4
		END DO
	END DO
	!$acc end kernels
	! Use FFT to find mean
	CALL cufftExecZ2Z(plan,temp1,temp2,CUFFT_FORWARD)
	!$acc end data
	InEner=temp2(1,1)
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=kx(i)*v(i,j)*scalemodes
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_INVERSE)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=0.5d0*abs(temp1(i,j))**2
		END DO
	END DO
	!$acc end kernels
	! Use FFT to find mean
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_FORWARD)
	!$acc end data
	InEner=InEner+temp1(1,1)
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=ky(j)*v(i,j)*scalemodes
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_INVERSE)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=0.5d0*abs(temp1(i,j))**2
		END DO
	END DO
	!$acc end kernels
	! Use FFT to find mean
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_FORWARD)
	!$acc end data
	InEner=InEner+temp1(1,1)
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)
	CALL cpu_time(start_time)

	! transform initial data and do first half time step
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx
			v(i,j)=exp(0.5d0*dt*(kx(i)*kx(i) + ky(j)*ky(j))&
					*cmplx(0.0d0,1.0d0))*v(i,j)
		END DO
	END DO
	!$acc end kernels
	PRINT *,'Got initial data, starting timestepping'
	time(1)=0.0d0
	DO n=1,Nt
		CALL cufftExecZ2Z(plan,v,u,CUFFT_INVERSE)
	    !$acc kernels loop gang(gangsize), vector(vecsize)
		DO j=1,Ny
			DO i=1,Nx
				v(i,j)=Es*u(i,j)*conjg(u(i,j))*scalemodes**2
			END DO
		END DO
	    !$acc end kernels
	    !$acc kernels loop gang(gangsize), vector(vecsize)
		DO j=1,Ny
			DO i=1,Nx
				u(i,j)=exp(cmplx(0.0d0,-1.0d0)*dt*v(i,j))&
						*u(i,j)*scalemodes
			END DO
		END DO
	    !$acc end kernels
		CALL cufftExecZ2Z(plan,u,v,CUFFT_FORWARD)
	    !$acc kernels loop gang(gangsize), vector(vecsize)
		DO j=1,Ny
			DO i=1,Nx
				v(i,j)=exp(dt*(kx(i)*kx(i) + ky(j)*ky(j))&
						*cmplx(0.0d0,1.0d0))*v(i,j)
			END DO
		END DO
	    !$acc end kernels
		IF (mod(n,plotgap)==0) then
			time(1+n/plotgap)=n*dt
			PRINT *,'time',n*dt
		END IF
	END DO
	! transform back final data and do another half time step
	CALL cufftExecZ2Z(plan,v,u,CUFFT_INVERSE)
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx
			v(i,j)=Es*u(i,j)*conjg(u(i,j))*scalemodes**2
		END DO
	END DO
	!$acc end kernels
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx
			u(i,j)=exp(cmplx(0,-1)*dt*v(i,j))*u(i,j)*scalemodes
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2Z(plan,u,v,CUFFT_FORWARD)
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx
			v(i,j)=exp(0.5d0*dt*(kx(i)*kx(i) + ky(j)*ky(j))&
					*cmplx(0.0d0,1.0d0))*v(i,j)
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2Z(plan,v,u,CUFFT_INVERSE)
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx
			u(i,j)=u(i,j)*scalemodes
		END DO
	END DO
	!$acc end kernels
	PRINT *,'Finished time stepping'
	CALL cpu_time(stop_time)
	!$acc end data
	PRINT*,'Program took ',stop_time-start_time,&
		'for Time stepping'
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)

	! calculate final mass
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp1(i,j)=abs(u(i,j))**2
		END DO
	END DO
	!$acc end kernels
	! Use FFT to get initial mass
	CALL cufftExecZ2Z(plan,temp1,temp2,CUFFT_FORWARD)
	!$acc end data
	FiMass=temp2(1,1)

	! Get final energy
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp1(i,j)=-ES*0.25d0*abs(u(i,j))**4
		END DO
	END DO
	!$acc end kernels
	! Use FFT to find mean
	CALL cufftExecZ2Z(plan,temp1,temp2,CUFFT_FORWARD)
	!$acc end data
	FiEner=temp2(1,1)
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=kx(i)*v(i,j)*scalemodes
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_INVERSE)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=0.5d0*abs(temp1(i,j))**2
		END DO
	END DO
	!$acc end kernels
	! Use FFT to find mean
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_FORWARD)
	!$acc end data
	FiEner=FiEner+temp1(1,1)
	!$acc data copy(InMass,FiMass,InEner,FiEner,kx,ky,x,y,u,v,temp1,temp2,time)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=ky(j)*v(i,j)*scalemodes
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_INVERSE)
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=0.5d0*abs(temp1(i,j))**2
		END DO
	END DO
	!$acc end kernels
	! Use FFT to find mean
	CALL cufftExecZ2Z(plan,temp2,temp1,CUFFT_FORWARD)
	!$acc end data
	FiEner=FiEner+temp1(1,1)

 	PRINT *,'Results copied back to host'
	PRINT*,'Initial mass',InMass
	PRINT*,'Final mass',FiMass
	PRINT*,'Final Mass/Initial Mass', &
	   ABS(REAL(FiMass,kind(0d0))/REAL(InMass,kind(0d0)))
	PRINT*,'Initial energy',InEner
	PRINT*,'Final energy',FiEner
	PRINT*,'Final Energy/Initial Energy', &
	   ABS(REAL(FiEner,kind(0d0))/REAL(InEner,kind(0d0)))

	name_config = 'ufinal.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		DO i=1,Nx
			WRITE(11,*) abs(u(i,j))**2
		END DO
	END DO
	CLOSE(11)

	name_config = 'tdata.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,1+Nt/plotgap
		WRITE(11,*) time(j)
	END DO
	CLOSE(11)

	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	name_config = 'ycoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		WRITE(11,*) y(j)
	END DO
	CLOSE(11)
	PRINT *,'Saved data'

	CALL cufftDestroy(plan)

	DEALLOCATE(u,v,temp1,temp2,time,kx,ky,x,y,stat=allocatestatus)
	IF (allocatestatus .ne. 0) STOP
	PRINT *,'Deallocated memory'

   	PRINT *,'Program execution complete'
	END PROGRAM main


! **
! * Provides the cumulative distribution function (CDF) of the normal distribution
! **
module normal_cdf
    use kinds, only: dp
    implicit none
    private
    public :: cdf_normal

    contains

        ! **
        ! * Returns the value of the normal cumulative distribution function for a given x.
        ! *
        ! * Input:
        ! *     - x: the x, at which the CDF is evaluated
        ! *
        ! * Return value: the value of the CDF of the normal distribution at x
        ! **
        real(dp) function cdf_normal(x)
            real(dp), intent(in)   :: x
            real(dp)               ::q,pdf

            call nprob(x,cdf_normal, q, pdf)
        end function cdf_normal

        subroutine nprob(z,p,q,pdf)
            real(dp), intent(in)   :: z
            real(dp), intent(out)  :: p,q,pdf
            real(dp)               :: a0,a1,a2,a3,a4,a5,a6,a7,b0,b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11
            real(dp)               :: y, zabs
        !           Reference: Adams,A.G. Areas under the normal curve,
        !           Algorithm 39, Computer J., Vol. 12, 197-8, 1969.
        !
        !           Latest Revision - 23 January 1981
        !           Obtained from: http://lib.stat.cmu.edu/apstat/
        !           April 10, 2013: modified by Carlo Zanella:
        !               - adapted to the variable naming of this program
        !               - explicit variable declarations
        !               - specified intents of dummy arguments
        !

            data a0,a1,a2,a3,a4,a5,a6,a7/0.5d0, 0.398942280444d0, &
           0.399903438504d0, 5.75885480458d0, 29.8213557808d0, &
           2.62433121679d0, 48.6959930692d0, 5.92885724438d0/, &
           b0,b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11/0.398942280385d0, &
           3.8052d-8, 1.00000615302d0, 3.98064794d-4, 1.98615381364d0, &
           0.151679116635d0, 5.29330324926d0, 4.8385912808d0, &
           15.1508972451d0, 0.742380924027d0, 30.789933034d0, &
           3.99019417011d0/
        !
            zabs = abs(z)
            if(zabs.gt.12.7d0) go to 20
            y = a0*z*z
            pdf = exp(-y)*b0
            if(zabs.gt.1.28d0) go to 10
        !
        !       z between -1.28 and +1.28
        !
            q = a0-zabs*(a1-a2*y/(y+a3-a4/(y+a5+a6/(y+a7))))
            if(z.lt.0.d0) go to 30
            p = 1.d0-q
            return
        !
        !       zabs between 1.28 and 12.7
        !
        10   q = pdf/(zabs-b1+b2/(zabs+b3+b4/(zabs-b5+b6/(zabs+b7-b8/(zabs+b9+b10/(zabs+b11))))))
            if(z.lt.0.d0) go to 30
            p = 1.d0-q
            return
        !
        !       z far out in tail
        !
        20   q = 0.d0
            pdf = 0.d0
            if(z.lt.0.d0) go to 30
            p = 1.d0
            return
        !
        !       negative z, interchange p and q
        !
        30   p = q
            q = 1.d0-p
            return
        end subroutine nprob

end module normal_cdf


      program DRSSVA
c>> 1996-06-27 DRSSVA   Krogh  Special code for C conversion.
c>> 1996-05-28 DRSSVA   Krogh  Removed implicit statement.
c>> 1994-10-19 DRSSVA   Krogh  Changes to use M77CON
c>> 1989-03-07 DRSSVA   CLL
c     Demo driver for SSVA, Singular Value Analysis.
c
c     Mar 1987, C. L. Lawson & S. Y. Chiu, JPL.  This sample problem
c     taken from the book, Solving Least Squares Problems,
c     Prentice-Hall, 1974, by C. L. Lawson and R. J. Hanson.
c     ------------------------------------------------------------------
c--S replaces "?": DR?SVA, ?SVA
c     ------------------------------------------------------------------
      integer I, J, KPVEC(4), M, MDATA, MMAX, N, NMAX, NMAX2
      parameter(MMAX = 15, NMAX = 5, NMAX2 = NMAX*2)
      real             A(MMAX,NMAX), B(MMAX), SING(NMAX)
      real             D(NMAX), WORK(NMAX2)
      character*6 NAMES(NMAX)
c
      data ((A(I,J),J=1,5),I=1,15) /
     *-.13405547E0,-.20162827E0,-.16930778E0,-.18971990E0,-.17387234E0,
     *-.10379475E0,-.15766336E0,-.13346256E0,-.14848550E0,-.13597690E0,
     *-.08779597E0,-.12883867E0,-.10683007E0,-.12011796E0,-.10932972E0,
     * .02058554E0, .00335331E0,-.01641270E0, .00078606E0, .00271659E0,
     *-.03248093E0,-.01876799E0, .00410639E0,-.01405894E0,-.01384391E0,
     * .05967662E0, .06667714E0, .04352153E0, .05740438E0, .05024962E0,
     * .06712457E0, .07352437E0, .04489770E0, .06471862E0, .05876455E0,
     * .08687186E0, .09368296E0, .05672327E0, .08141043E0, .07302320E0,
     * .02149662E0, .06222662E0, .07213486E0, .06200069E0, .05570931E0,
     * .06687407E0, .10344506E0, .09153849E0, .09508223E0, .08393667E0,
     * .15879069E0, .18088339E0, .11540692E0, .16160727E0, .14796479E0,
     * .17642887E0, .20361830E0, .13057860E0, .18385729E0, .17005549E0,
     * .11414080E0, .17259611E0, .14816471E0, .16007466E0, .14374096E0,
     * .07846038E0, .14669563E0, .14365800E0, .14003842E0, .12571177E0,
     * .10803175E0, .16994623E0, .14971519E0, .15885312E0, .14301547E0 /
c
      data (B(I),I=1,15) /
     *-.4361E0, -.3437E0, -.2657E0, -.0392E0, .0193E0, .0747E0,
     * .0935E0,  .1079E0, .1930E0, .2058E0, .2606E0, .3142E0,
     * .3529E0, .3615E0, .3647E0 /
c
      data NAMES /'Earth ', 'Water ', 'Air   ', 'Fire  ', 'Time  '/
      data KPVEC / 1, 111111, -1, 76/
c     ------------------------------------------------------------------
c
      M = MMAX
      N = NMAX
      MDATA = M
      print '(''   DRSSVA..    Demonstrate Singular Value Analysis''/
     *   ''   Listing of input matrix, A, and vector, B, follows..'')'
c++ Code for ~.C. is active
      print '(/(5F12.7,F13.4))',
     *      ((A(I,J),J=1,N),B(I),I=1,M)
c++ Code for .C. is inactive
c%%  for (i = 1; i <= m; i++){
c%%     printf( "\n" );
c%%     for (j = 1; j <= n; j++)
c%%        printf( "%12.7f", a[j - 1][i - 1] );
c%%     printf( "%13.4f", B[i] );}
c%%  fprintf( stdout, " \n\n\n \n" );
c++ End
      print '(1X///1X)'
c
      call SSVA(A, MMAX, M, N, MDATA, B, SING, KPVEC, NAMES, 1, D, WORK)
c
      stop
      end


MODULE class_Circle
  IMPLICIT NONE
  PRIVATE
  REAL :: pi = 3.1415926535897931d0 ! Class-wide private constant

  TYPE, PUBLIC :: Circle
     REAL :: radius
   CONTAINS
     PROCEDURE :: area => circle_area
     PROCEDURE :: PRINT => circle_print
  END TYPE Circle
CONTAINS
  FUNCTION circle_area(this) RESULT(area)
    CLASS(Circle), INTENT(in) :: this
    REAL :: area
    area = pi * this%radius**2
  END FUNCTION circle_area

  SUBROUTINE circle_print(this)
    CLASS(Circle), INTENT(in) :: this
    REAL :: area
    area = this%area()  ! Call the type-bound function
    PRINT *, 'Circle: r = ', this%radius, ' area = ', area
  END SUBROUTINE circle_print
END MODULE class_Circle

PROGRAM circle_test
  USE class_Circle
  IMPLICIT NONE

  TYPE(Circle) :: c     ! Declare a variable of type Circle.
  c = Circle(1.5)       ! Use the implicit constructor, radius = 1.5.
  CALL c%PRINT          ! Call the type-bound subroutine
END PROGRAM circle_test


module triangle_m
    implicit none
    private
    public :: triangle_t

    type :: triangle_t
        private
        real :: height_, width_
    contains
        procedure :: area
    end type

    interface triangle_t
        module procedure construct
    end interface
contains
    pure function construct(height, width) result(triangle)
        real, intent(in) :: height, width
        type(triangle_t) :: triangle

        triangle%height_ = height
        triangle%width_ = width
    end function

    pure function area(self)
        class(triangle_t), intent(in) :: self
        real :: area

        area = 0.5 * self%height_ * self%width_
    end function
end module


*
* Call with many array references
*
      SUBROUTINE RESID(U,V,R,N,A)
      INTEGER N
      REAL*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
      INTEGER I3, I2, I1
C
      DO 600 I3=2,N-1
      DO 600 I2=2,N-1
      DO 600 I1=2,N-1
         R(I1,I2,I3)=V(I1,I2,I3)
     >      -A(0)*( U(I1,  I2,  I3  ) )
     >      -A(1)*( U(I1-1,I2,  I3  ) + U(I1+1,I2,  I3  )
     >                 +  U(I1,  I2-1,I3  ) + U(I1,  I2+1,I3  )
     >                 +  U(I1,  I2,  I3-1) + U(I1,  I2,  I3+1) )
     >      -A(2)*( U(I1-1,I2-1,I3  ) + U(I1+1,I2-1,I3  )
     >                 +  U(I1-1,I2+1,I3  ) + U(I1+1,I2+1,I3  )
     >                 +  U(I1,  I2-1,I3-1) + U(I1,  I2+1,I3-1)
     >                 +  U(I1,  I2-1,I3+1) + U(I1,  I2+1,I3+1)
     >                 +  U(I1-1,I2,  I3-1) + U(I1-1,I2,  I3+1)
     >                 +  U(I1+1,I2,  I3-1) + U(I1+1,I2,  I3+1) )
     >      -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
     >                 +  U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
     >                 +  U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
     >                 +  U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )

 600  CONTINUE
C
C
      RETURN
      END


module UtilitiesM
!!$ Intrinsic standart iso_fortran Real types REAL32, REAL64, REAL128
  use, intrinsic :: iso_fortran_env
  implicit none

  public :: isp, idp, iqp, ikind, rsp, rdp, rqp, rkind!, debugger

  integer, parameter :: isp = int16
  integer, parameter :: idp = int32
  integer, parameter :: iqp = int64
  integer, parameter :: rsp = REAL32
  integer, parameter :: rdp = REAL64
  integer, parameter :: rqp = REAL128
  integer, parameter :: ikind = idp
  integer, parameter :: rkind = rdp

  interface assignAnyTypeToR8
     procedure assignAnyTypeToR8Scalar
     procedure assignAnyTypeToR8Array
  end interface assignAnyTypeToR8

contains

  subroutine assignAnyTypeToR8Scalar(output,input)
    implicit none
    real(rkind), intent(out) :: output
    class(*), intent(in) :: input
    select type(input)
    type is(integer)
       output=input
    type is(real(rsp))
       output=input
    type is(real(rdp))
       output=input
    type is(real(rqp))
       output=input
    type is(character(*))
       write(*,*) 'Wrong type of argument input!'
       stop
    end select
  end subroutine assignAnyTypeToR8Scalar

  subroutine assignAnyTypeToR8Array(output,input)
    implicit none
    real(rkind), intent(out), dimension(:) :: output
    class(*), intent(in), dimension(:) :: input
    select type(input)
    type is(integer)
       output=input
    type is(real(rsp))
       output=input
    type is(real(rdp))
       output=input
    type is(real(rqp))
       output=input
    type is(character(*))
       write(*,*) 'Wrong type of argument input!'
       stop
    end select
  end subroutine assignAnyTypeToR8Array

  pure function matinv2(A) result(B)
    !! Performs a direct calculation of the inverse of a 2×2 matrix.
    real(rkind), intent(in) :: A(2,2)   !! Matrix
    real(rkind)             :: B(2,2)   !! Inverse matrix
    real(rkind)             :: detinv

    ! Calculate the inverse determinant of the matrix
    detinv = 1/(A(1,1)*A(2,2) - A(1,2)*A(2,1))

    ! Calculate the inverse of the matrix
    B(1,1) = +detinv * A(2,2)
    B(2,1) = -detinv * A(2,1)
    B(1,2) = -detinv * A(1,2)
    B(2,2) = +detinv * A(1,1)
  end function

  pure function matinv3(A) result(B)
    !! Performs a direct calculation of the inverse of a 3×3 matrix.
    real(rkind), intent(in) :: A(3,3)   !! Matrix
    real(rkind)             :: B(3,3)   !! Inverse matrix
    real(rkind)             :: detinv

    ! Calculate the inverse determinant of the matrix
    detinv = 1/(A(1,1)*A(2,2)*A(3,3) - A(1,1)*A(2,3)*A(3,2)&
              - A(1,2)*A(2,1)*A(3,3) + A(1,2)*A(2,3)*A(3,1)&
              + A(1,3)*A(2,1)*A(3,2) - A(1,3)*A(2,2)*A(3,1))

    ! Calculate the inverse of the matrix
    B(1,1) = +detinv * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
    B(2,1) = -detinv * (A(2,1)*A(3,3) - A(2,3)*A(3,1))
    B(3,1) = +detinv * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
    B(1,2) = -detinv * (A(1,2)*A(3,3) - A(1,3)*A(3,2))
    B(2,2) = +detinv * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
    B(3,2) = -detinv * (A(1,1)*A(3,2) - A(1,2)*A(3,1))
    B(1,3) = +detinv * (A(1,2)*A(2,3) - A(1,3)*A(2,2))
    B(2,3) = -detinv * (A(1,1)*A(2,3) - A(1,3)*A(2,1))
    B(3,3) = +detinv * (A(1,1)*A(2,2) - A(1,2)*A(2,1))
  end function

  pure function matinv4(A) result(B)
    !! Performs a direct calculation of the inverse of a 4×4 matrix.
    real(rkind), intent(in) :: A(4,4)   !! Matrix
    real(rkind)             :: B(4,4)   !! Inverse matrix
    real(rkind)             :: detinv

    ! Calculate the inverse determinant of the matrix
    detinv = &
      1/(A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))&
       - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))&
       + A(1,3)*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))&
       - A(1,4)*(A(2,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(2,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(2,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1))))

    ! Calculate the inverse of the matrix
    B(1,1) = detinv*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))
    B(2,1) = detinv*(A(2,1)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(2,3)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(2,4)*(A(3,3)*A(4,1)-A(3,1)*A(4,3)))
    B(3,1) = detinv*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(4,1) = detinv*(A(2,1)*(A(3,3)*A(4,2)-A(3,2)*A(4,3))+A(2,2)*(A(3,1)*A(4,3)-A(3,3)*A(4,1))+A(2,3)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(1,2) = detinv*(A(1,2)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(1,3)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(1,4)*(A(3,3)*A(4,2)-A(3,2)*A(4,3)))
    B(2,2) = detinv*(A(1,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(1,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(1,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))
    B(3,2) = detinv*(A(1,1)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(1,2)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(1,4)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(4,2) = detinv*(A(1,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(1,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(1,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(1,3) = detinv*(A(1,2)*(A(2,3)*A(4,4)-A(2,4)*A(4,3))+A(1,3)*(A(2,4)*A(4,2)-A(2,2)*A(4,4))+A(1,4)*(A(2,2)*A(4,3)-A(2,3)*A(4,2)))
    B(2,3) = detinv*(A(1,1)*(A(2,4)*A(4,3)-A(2,3)*A(4,4))+A(1,3)*(A(2,1)*A(4,4)-A(2,4)*A(4,1))+A(1,4)*(A(2,3)*A(4,1)-A(2,1)*A(4,3)))
    B(3,3) = detinv*(A(1,1)*(A(2,2)*A(4,4)-A(2,4)*A(4,2))+A(1,2)*(A(2,4)*A(4,1)-A(2,1)*A(4,4))+A(1,4)*(A(2,1)*A(4,2)-A(2,2)*A(4,1)))
    B(4,3) = detinv*(A(1,1)*(A(2,3)*A(4,2)-A(2,2)*A(4,3))+A(1,2)*(A(2,1)*A(4,3)-A(2,3)*A(4,1))+A(1,3)*(A(2,2)*A(4,1)-A(2,1)*A(4,2)))
    B(1,4) = detinv*(A(1,2)*(A(2,4)*A(3,3)-A(2,3)*A(3,4))+A(1,3)*(A(2,2)*A(3,4)-A(2,4)*A(3,2))+A(1,4)*(A(2,3)*A(3,2)-A(2,2)*A(3,3)))
    B(2,4) = detinv*(A(1,1)*(A(2,3)*A(3,4)-A(2,4)*A(3,3))+A(1,3)*(A(2,4)*A(3,1)-A(2,1)*A(3,4))+A(1,4)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)))
    B(3,4) = detinv*(A(1,1)*(A(2,4)*A(3,2)-A(2,2)*A(3,4))+A(1,2)*(A(2,1)*A(3,4)-A(2,4)*A(3,1))+A(1,4)*(A(2,2)*A(3,1)-A(2,1)*A(3,2)))
    B(4,4) = detinv*(A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)))
  end function

end module UtilitiesM


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  This module contains code for constructing Legendre quadratures and evaluating
!  Legendre polynomials.
!
!  The following routines should be regarded as public:
!
!    legequad - return the nodes and weights of the n-point Legendre quadrature
!      on the interval [-1,1]
!
!    legeexps - return the nodes and weights of the n-point Legendre quadrature
!      on the interval [-1,1] as well as the matrix which maps the scaled
!      values of Legendre expansions to their coefficients
!
!    leges - evaluate the Legendre polynomials of degrees 0 through n as well
!      as their derivatives at a specified point in the interval [-1,1]
!
!    leges0 - evaluate the Legendre polynomials of degrees 0 through n and
!      at a specified point in the interval [-1,1]
!
!    lege - evaluate a Legendre polynomial of degree n and its derivative at
!      a specified point on the interval [-1,1]
!
!    lege0 - evaluate a Legendre polynomial of degree n at a specified
!      point on the interval [-1,1]
!
!    legeeval - evaluate a Legendre expansion and its derivative at a
!      specified point
!
!    legeeval0 - evaluate a Legendre expansion at a specified point
!
!    legediff - return the spectral differentiation matrix which takes
!      the scaled values of an n-term Legendre expansion at the
!      Legendre nodes to the scaled values of its derivative at the
!      Legendre nodes
!
!    legeint - return the spectral integration matrix which takes the
!      scaled values of an n-term Legendre expansion at the nodes of
!      the n-point Legnedre quadrature to the scaled values of its
!      antiderivative at those same nodes
!
!    legeq - evaluate the Legendre function of the second kind at a
!      user-specified point in the complex plane
!
!    legen - evaluate the normalized Legendre polynomials of degrees 0 through n
!      at a user-specified point in the interval [-1,1]
!
!    lege_stieltjes - evaluate P_\nu(\cos(\theta)) on the interval (1/nu, \pi/2)
!      using Stieltjes' asymptoptic formula
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module legendre

use utils

contains

subroutine legequad(n,xs,whts)
implicit double precision (a-h,o-z)
!
double precision, allocatable, intent(out) :: xs(:),whts(:)
integer n
!
!  Return the nodes and weights of the n-point Legendre quadrature on the interval
!  [-1,1].   This quadrature integrates polynomials of degree less than or equal
!  to 2n-1 exactly.
!
!  An O(n^2) algorithm is used to construct the quadrature formula when n is small
!  and the GLR algorithm is used when n is larger.
!
!  Input parameters:
!
!    n - an integer specifying the number of points to
!
!  Output parameters:
!
!    xs - upon return, a vector of length n specifying the nodes of the n-point
!      Legendre quadrature
!    whts - upon return, a of length n specifying the nodes of n-point
!      Legendre quadrature
!

double precision pols(n+1)
allocate(xs(n),whts(n))

maxiters = 10
pi       = acos(-1.0d0)

!
!  Obtain machine zero.
!

call mach_zero(eps0)

if ( n .gt. 150) then
call legequad2(n,xs,whts)
return
endif

!
!   Use Newton's method and the recurrence relation to find half of the
!   roots --- the others are obtained via symmetry.
!
!   Note that we also store the value of the derivative at each of the obtained
!   roots for use in computing the weights below.
!
ifodd = 0
nn = (n+1)/2
if (nn /= n/2) then
ifodd=1
nn=nn-1
endif

!
!  Use Tricomi's formula to  estimate the roots of P_{n+1}
!

do i =nn+1,n
   dk = i-nn-1
   dn = n
   theta = (4*(ceiling(dn/2)-dk)-1) / (4*dn+2) * pi
   x0 = 1.0d0 - (dn-1)/(8*dn**3)-1.0d0/(384.0d0*dn**4)* &
        (39.0d0-28.0d0/sin(theta)**2)
   xs(i)=x0*cos(theta)
enddo

!
!  Perform Newton iterations in order to refine the estimates.
!
do iter = 1,maxiters

!
!  Evaluate the Legendre polynomial of degree n at each point; save
!  the values of the derivative in the whts array.
!
do i=nn+1,n
call lege(n,xs(i),pols(i),whts(i))
end do

!
!  Perform one Newton iteration
!
pols(nn+1:n) = pols(nn+1:n)/whts(nn+1:n)
xs(nn+1:n)   = xs(nn+1:n) - pols(nn+1:n)

if(norm2(pols(nn+1:n)) < eps0) then
exit
endif

end do

if (iter == maxiters)  then
print *,"legequad failed!"
stop
end if

!
! Compute the weights using the derivatives we stored above.
!
do j=nn+1,n
   x       = xs(j)
   dd      = 2.0d0/(1.0d0-x**2)
   whts(j) = dd/(whts(j)**2)
end do

!
! Reflect the quadrature nodes.
!
do j=1,nn
xs(j)   = -xs(n-j+1)
whts(j) = whts(n-j+1)
end do

!
! Handle the root at 0 if n is odd.
!

if (ifodd .eq. 1) then
x0          = 0
call lege(n,x0,pol,der)
xs(nn+1)   = x0
whts(nn+1) = 2.0d0/(der**2)
endif

end subroutine

subroutine legequad2(n,xs,whts)
implicit double precision (a-h,o-z)
dimension xs(n),whts(n)
data pi /3.14159265358979323846264338327950288d0/
!
!  Use Newton's method and local Taylor expansions (i.e., the Glaser-Liu Rokhlin method)
!  to compute the n roots of the Legendre polynomial of degree n.  This routine
!  is O(n) in the number of nodes n.

maxiters = 12
call mach_zero(eps0)
eps0=eps0*10
k        = 30
!
!  Find the roots in [0,1]
!
        ifodd = 0
        nn = (n+1)/2
        if (nn .ne. n/2) then
        ifodd=1
        nn=nn-1
        endif
!
!  Use a negative value of x0 to indicate that the procedure has
!  not been initialized.
!
!
        x0 = -1
!
        do 2000 i=nn+1,n
!
!       Use Chebyshev node as initial guess for roots ...
!
!        x1 = cos(-pi+(2*i-1)*pi/(2*n))
!
!       ... or use this somewhat better approximation.
!
        dk = i-nn-1
        dn = n
        theta = (4*(ceiling(dn/2)-dk)-1) / (4*dn+2) * pi

        x1 = 1.0d0 - (dn-1)/(8*dn**3)-1.0d0/(384.0d0*dn**4)*   &
            (39.0d0-28.0d0/sin(theta)**2)
!
        x1=x1*cos(theta)
!
!       Conduct Newton iterations.
!
        do 2100 iter=1,maxiters
!
!       Evaluate the nth polynomial at x1 using a Taylor expansion
!       and the recurrence relation.  The first evaluation must be
!       handled specially.
!
        if (x0 .lt. 0) then
        call lege(n,x1,pol,der)
        else
        dx = x1-x0
        call legetayl(n,k,x0,dx,pol,der)
        endif
!
!       Newton iteration.
!
        x0 = x1
        dd = -pol/der
        x1 = x0+dd
!
        if (abs(dd) .lt. eps0) then
        xs(i)=x1
        whts(i)=der
        goto 2000
        endif
!
 2100 continue
!
!       This doesn't happen.
!
        print *,"legeroots bombed!"
        stop
 2000 continue
!
!       Compute the weights using the derivatives we stored above.
!
        do 3000 j=nn+1,n
        x       = xs(j)
        dd      = 2.0d0/(1-x**2)
        whts(j) = dd/whts(j)**2
 3000 continue
!
!       Reflect the quadrature on [-1,0] to [0,1].
!
        do 4000 j=1,nn
        xs(j)   = -xs(n-j+1)
        whts(j) = whts(n-j+1)
 4000 continue
!
!       Handle the root at 0 if n is odd.
!
        if (ifodd .eq. 1) then
        x0          = 0
        call lege(n,x0,pol,der)
!
        xs(nn+1)   = x0
        whts(nn+1) = 2.0d0/der**2
        endif
!
end subroutine

        subroutine legetayl(n,k,x,dx,pol,der)
        implicit double precision (a-h,o-z)
!
!       Evaluate the Legendre polynomial of order n using a Taylor
!       expansion and the recurrence relation for the power series
!       coefficients.
!
        k0 = min(k,n)
        p1     = pol
        p2     = der*dx
        sum    = p1+p2
        sumder = p2/dx
        do 1000 j=0,k0-2
        d = 2*x*(j+1.0d0)**2/dx*p2-(n*(n+1.0d0)-j*(j+1.0d0))*p1
        d = d/(j+1.0d0)/(j+2.0d0)*dx**2/(1.0d0-x**2)
        sum    = sum+d
        sumder = sumder+d*(j+2)/dx
        p1 = p2
        p2 = d
 1000 continue
        pol = sum
        der = sumder
        end subroutine

subroutine legeexps(n,xs,whts,u)
implicit double precision (a-h,o-z)
integer n
double precision, allocatable, intent(out) :: xs(:),whts(:),u(:,:)
!
!  Return the nodes x_1,...,x_n and weights w_1,...,w_n of the n-point
!  Legendre quadrature on the interval [-1,1].  Also, construct the
!  matrix u taking the scaled values of a n-term Legendre expansion
!  at the nodes of the n-point Legendre quadrature to its coefficients.
!  That is, if f is a polynomial of degree n-1 whose Legendre expansion is
!
!      f(x) = \sum_{j=0}^{n-1} a_j P_j(x)
!
!  then u is the matrix taking the vector
!
!     ( f(x_1) \sqrt{w_1} )
!     ( f(x_1) \sqrt{w_2} )
!             .
!             .                                                                       (1)
!             .
!     ( f(x_n) \sqrt{w_n} )
!
!   of scaled function values to the vector
!
!
!     (a_0    )
!     (a_1    )
!       .
!       .                                                                             (2)
!       .
!     (a_{n-1})
!
!
!
!
!  Input parameters:
!
!    n - the length of the Legendre quadrature to construct
!
!  Output parameters:
!
!    xs - the nodes of the n-point Legendre quadrature on the interval [-1,1]
!    whts - this array
!    u - the (n,n) matrix which maps the scaled values (1) of a
!      polynomial of degree n-1 to the coefficients (2) in its Legendre expansion
!
!      Since this matrix is orthogonal, its transpose takes the coefficients
!      of the Legendre expansion (2) to its scaled values at the nodes of
!      the n-point Legendre quadrature.
!

!
!  Call legequad to construct the n-point quadrature formula
!
call legequad(n,xs,whts)

!
!  Construct the matrix u.
!
allocate(u(n,n))

do i=1,n
call leges0(n-1,xs(i),u(:,i))
u(:,i) = u(:,i)*sqrt(whts(i))
end do

do j=1,n
dd = (2*j-1)/2.0d0
u(j,:) = u(j,:)*dd
end do

end subroutine

subroutine leges(n,x,pols,ders)
implicit double precision (a-h,o-z)

double precision, intent(out) :: pols(n+1),ders(n+1)
double precision x
integer n
!
!  Evaluate the n+1 nLegendre polynomials of degree 0 through n at the
!  point x using the standard 3-term recurrence relation.  Return the values
!  of their derivative at the point x as well.
!
!  Input parameters:
!
!    n - an integer specifying the order of polynomials which are to
!      be evaluated
!    x - the point at which the polynomials and their derivatives
!
!  Output parameters:
!
!    pols - the ith entry of this user-supplied array of length n+1
!      will contain the value of normalized Legendre polynomial of degree
!      i-1 at x
!    ders - the ith entry of this user-supplied array will contain the
!      value of the derivative of the normalized Legendre polynomial
!
!

pols(1) = 1
ders(1) = 0

if (n >= 1) then
pols(2) = x
ders(2) = 1
end if

!
!  Calculate the values of the unnormalized polynomials
!
do j=2,n
   pols(j+1)=((2.0d0*j-1.0d0)*x*pols(j)-(j-1.0d0)*pols(j-1))/j
end do

!
!  Compute the derivatives of the unnormalized polynoials
!
d=x**2.0d0-1.0d0
do j=3,n+1
   ders(j)=(j-1.0d0)*(x*pols(j)-pols(j-1))/d
end do

end subroutine

subroutine leges0(n,x,pols)
implicit double precision (a-h,o-z)

double precision, intent(out) :: pols(n+1)
double precision x
integer n
!
!  Evaluate the n+1 Legendre polynomials of degree 0 through n at the
!  point x using the standard 3-term recurrence relation.
!
!  Input parameters:
!
!    n - an integer specifying the order of polynomials which are to
!      be evaluated
!    x - the point at which the polynomials and their derivatives
!
!  Output parameters:
!
!    pols - the ith entry of this user-supplied array of length n+1
!      will contain the value of P_{i-1}(t)
!

pols(1) = 1

if (n >= 1) then
pols(2) = x
end if

!
!  Calculate the values of the polynomials
!

do j=2,n
pols(j+1)=((2.0d0*j-1.0d0)*x*pols(j)-(j-1.0d0)*pols(j-1))/j
end do

end subroutine

subroutine leges2(n,x,pols,ders,ders2)
implicit double precision (a-h,o-z)

double precision, intent(out) :: pols(n+1),ders(n+1),ders2(n+1)
double precision x
integer n
!
!  Evaluate the n+1 Legendre polynomials of degree 0 through n at the
!  point x using the standard 3-term recurrence relation.  Return the values
!  of their first and second derivatives at the point x as well.
!
!  Input parameters:
!
!    n - an integer specifying the order of polynomials which are to
!      be evaluated
!    x - the point at which the polynomials and their derivatives
!
!  Output parameters:
!
!    pols - the ith entry of this user-supplied array of length n+1
!      will contain the value of normalized Legendre polynomial of degree
!      i-1 at x
!    ders - the ith entry of this user-supplied array will contain the
!      value of the derivative of the normalized Legendre polynomial
!      of degree i-1 at x
!    ders2 - the ith entry of this user-supplied array will contain
!      the value of the second derivative of the normalized Legendre
!      polynomial of degree i-1 at x
!
!

pols(1)  = 1
ders(1)  = 0
ders2(1) = 0

if (n >= 1) then
pols(2)  = x
ders(2)  = 1
ders2(2) = 0
end if

!
!  Calculate the values of the unnormalized polynomials
!
do j=2,n
   pols(j+1)=((2.0d0*j-1.0d0)*x*pols(j)-(j-1.0d0)*pols(j-1))/j
end do

!
!  Compute the derivatives of the unnormalized polynoials
!
d=x**2.0d0-1.0d0
do j=3,n+1
   ders(j)=(j-1.0d0)*(x*pols(j)-pols(j-1))/d
end do

!
!  Compute the second derivatives of the unnormalized polynomials
!
do j=3,n+1
  ders2(j) = (j-1)/d * (pols(j)+ ( (j-1)*x-2*x) /(j-1) * ders(j) - ders(j-1))
end do

end subroutine

subroutine lege(n,x,pol,der)
implicit double precision (a-h,o-z)
integer n
double precision x,pol
!
!  Evaluate the Legendre polynomial of degree n and its derivative at
!  the point x.
!
!  Input parameters:
!
!    n - the degree of the polynomial to evaluate
!    x - the point at which the polynomial is to be evaluated
!
!  Output parameters:
!
!    pol - the value of P_n(x)
!    der - the value of P_n'(x)
!

if (n == 0) then
pol = 1
der = 0
else if (n == 1) then
pol = x
der = 1.0d0
else
p1 = 1
p2 = x

do j=2,n
   p  = ((2*j-1)*x*p2-(j-1)*p1)/j
   p1 = p2
   p2 = p
end do
!
pol = p
!
! Compute the derivative using another well-known formula.
!
der=n*(x*p2-p1)/(x**2-1.0d0)
endif

end subroutine

subroutine lege0(n,x,pol)
implicit double precision (a-h,o-z)
integer n
double precision x,pol
!
!  Evaluate the Legendre polynomial of degree n at the point x.
!
!  Input parameters:
!
!    n - the degree of the polynomial to evaluate
!    x - the point at which the polynomial is to be evaluated
!
!  Output parameters:
!
!    pol - the value of P_n(x)
!

if (n == 0) then
pol = 1.0d0
else if (n == 1) then
pol = x
else
p1 = 1
p2 = x

do j=2,n
   p  = ((2*j-1)*x*p2-(j-1)*p1)/j
   p1 = p2
   p2 = p
end do

pol = p
endif

end subroutine

subroutine legeeval(n,coefs,x,val,der)
implicit double precision (a-h,o-z)

integer n
dimension coefs(n)
double precision x,val,der

!
!  Evaluate an n-term Legendre expansion and its derivative at the point x.
!  That is, given n and a_0, a_1, ..., a_{n-1} evalute the function defined by
!
!             n
!    f(t) = \sum  a_j P_j(t),
!            j=0
!
!   where P_j is the jth Legendre polynomial, and its derivative
!   at the point x.
!
!  Input parameters:
!
!    n - the number of terms in the Legendre expansion
!    coefs - an array of length n containing the coefficients of the expansion
!    x - the point at which to evaluate the expansion
!
!  Output parameters:
!
!    val - the value of the expansion at the point x
!    der - the derivative of the expansion at the point x
!
!

dimension pols(n),ders(n)

val = 0
der = 0

call leges(n-1,x,pols,ders)

do i=1,n
val = val + pols(i)*coefs(i)
der = der + ders(i)*coefs(i)
end do

end subroutine

subroutine legeeval0(n,coefs,x,val)
implicit double precision (a-h,o-z)

integer n
dimension coefs(n)
double precision x,val

!
!  Evaluate an n-term Legendre expansion at the point x.  That is, given n
!  and a_0, a_1, ..., a_{n-1} evalute the function defined by
!
!             n
!    f(t) = \sum  a_j P_j(t),
!            j=0
!
!   where P_j is the jth Legendre polynomial at the point x.
!
!  Input parameters:
!
!    n - the number of terms in the Legendre expansion
!    coefs - an array of length n containing the coefficients of the expansion
!    x - the point at which to evaluate the expansion
!
!  Output parameters:
!
!    val - the value of the expansion at the point x
!

dimension pols(n),ders(n)

val = 0

call leges(n-1,x,pols,ders)

do i=1,n
val = val + pols(i)*coefs(i)
end do

end subroutine

subroutine legediff(n,xs,whts,u,a)
implicit double precision (a-h,o-z)

double precision, intent(in) :: xs(n),whts(n),u(n,n)
double precision, allocatable, intent(out) :: a(:,:)
!
!  Construct the (n,n) spectral differential matrix.  That is, the matrix
!  which takes scaled values of a function f at the Legendre nodes
!  to the scaled values of its derivative at the Legendre nodes.
!
!  Input parameters:
!
!    n - the number of Legendre nodes used to represent inputs and outputs
!    (xs,whts) - the nodes and weights of the n-point Legendre quadrature
!    u - the (n,n) matrix taking the scaled values of a Legendre expansion of
!      order n-1 to its coefficients
!    v - the (n,n) matrix inverse of u
!
!  Output parameters:
!
!    a - the (n,n) spectral differentiation matrix, which is allocated
!        by the routine
!

! double precision, allocatable :: xs0(:),whts0(:)
double precision, allocatable :: b(:,:)
double precision :: pols(n),ders(n)

! call legequad(n-1,xs0,whts0)

allocate(a(n,n),b(n,n))

!
!  Evaluate the derivatives of the Legendre polynomials at the
!  Legendre nodes.
!

do i=1,n
call leges(n-1,xs(i),pols,ders)
do j=1,n
b(i,j) = ders(j) *sqrt(whts(i))
end do
end do

!
!  Multiply that matrix by the matrix which takes scaled values to
!  coefficients in order to form the output matrix.
!

a = matmul(b,u)

end subroutine

subroutine legeint(n,xs,whts,u,a)
implicit double precision (a-h,o-z)

double precision, intent(in)  :: xs(n),whts(n),u(n,n)
double precision, intent(out) :: a(n,n)
!
!  Construct the (n,n) spectral integration matrix.  That is, the matrix
!  which takes scaled values of a Legendre
!  to the scaled values of its antiderivative at Legendre nodes.
!
!  Input parameters:
!
!    n -the number of
!    (xs,whts) - the nodes and weights of the n-point Legendre quadrature
!    u - the (n,n) matrix taking the scaled values of a Legendre expansion of
!      order n-1 to its coefficients
!
!  Output parameters:
!
!    a - the (n,n) spectral integration matrix
!

double precision, allocatable :: b(:,:)
double precision :: pols(n)

allocate(b(n,n))

!
!  Use the formula
!
!
!         t
!     \int P_n(x) dx =  ( t P_n(t) - P_{n-1}(t) ) / (n+1)
!        -1
!
!
!  to form the matrix of integrals of the Legendre polynomials at the
!  Legendre nodes.
!

do i=1,n
call leges0(n-1,xs(i),pols)

b(i,1) = (1+xs(i))*sqrt(whts(i))

do j=2,n
b(i,j) = (xs(i) * pols(j) - pols(j-1))/(j)
b(i,j) = b(i,j)*sqrt(whts(i))
end do
end do

!
!  Form the spectral integration matrix.
!
a = matmul(b,u)

end subroutine

subroutine legen(n,x,pols)
implicit double precision (a-h,o-z)

double precision, intent(out) :: pols(n+1)
double precision x
integer n
!
!  Evaluate the n+1 normalized Legendre polynomials of degree 0 through n at the
!  point x using the standard 3-term recurrence relation.
!
!  Input parameters:
!
!    n - an integer specifying the order of polynomials which are to
!      be evaluated
!    x - the point at which the polynomials and their derivatives
!
!  Output parameters:
!
!    pols - the ith entry of this user-supplied array of length n+1
!      will contain the value of P_{i-1}(t)
!

pols(1) = 1

if (n >= 1) then
pols(2) = x
end if

!
!  Calculate the values of the polynomials
!
do j=2,n
   pols(j+1)=((2.0d0*j-1.0d0)*x*pols(j)-(j-1.0d0)*pols(j-1))/j
end do

!
!  Normalize the polynomials.
!

do j=1,n+1
   dd = sqrt((2*(j-1)+1)/2.0d0)
   pols(j) = pols(j)*dd
end do

end subroutine

subroutine lege_stieltjes(dnu,t,val)
implicit double precision (a-h,o-z)

double precision, intent(in)     :: dnu,t
double precision, intent(out)    :: val

data pi           /3.14159265358979323846264338327950288q0/
data sqrt2overpi / 0.797884560802865355879892119868763737q0/
data piover2     / 1.57079632679489661923132169163975144q0/

val    = 0
nterms = 17
x      = dnu+0.75d0

dd = 1-1874409467055q0/(7.0368744177664q13*x**14)+  &
7426362705q0/(1.099511627776q12*x**12)-  &
20898423q0/(8.589934592q9*x**10)+180323/(1.34217728q8*x**8)-  &
671/(5.2428799999999995q5*x**6)+21/(8.192q3*x**4)-  &
1/(6.4q1*x**2)

c0  = 1.0d0/sqrt(x) * dd
dd  = 1.0d0
dd2 = 1/sin(t)

do m=0,nterms
a   = (dnu+m+0.5d0)*t-(m+0.5d0)*piover2
val = val + c0 * cos(a)*dd
dd  = dd*dd2
c0  = c0 * (m+0.5d0)**2/(2*(m+1.0d0)*(dnu+m+1.5d0))
end do

val = val * sqrt2overpi*sqrt(dd2)

end subroutine

end module


	SUBROUTINE VMATRIX(DATA,WT,NPT)
C
C	CALCULATES VARIANCE MATRIX AND EIGENVALUES
C
C	COMMON /PARTBLK/ XDATA(2050,4),XFDATA(2050,4),XGSE(2050,4),
C     1		XRE,YRE,ZRE,SUNCLOCK,SPINRATE,SPSS
	COMMON /VARMATX/ EVAL(3),EVECT(3,3)
	REAL DATA(2050,4),DATAS(2050,3),VMAT(3,3),WT(2050)
	REAL SN(3),CL(3),V3(3),AV(3),STD(3)
	INTEGER*4 SUNCLOCK
	DATA NSYS /-1/
C
C	THIS PROGRAM EXCLUDES GLITCH DATA BY USING WT
C
C	subtract averages
C
C	WRITE(79,*) ' '
C	WRITE(79,*) 'VARIANCE MATRIX,NPT=',NPT
C
	DO M = 1,3
	  AV(M) = 0.
	  COUNT = 0.
	  DO N = 1,NPT
		AV(M) = AV(M) + WT(N)*DATA(N,M)
		COUNT = COUNT+WT(N)
	  ENDDO
C	PRINT*,'M,AV,COUNT',M,AV(M),COUNT
	  AV(M) = AV(M)/COUNT
	ENDDO
	DO M = 1,3
	  DO N = 1,NPT
		DATAS(N,M) = WT(N)*(DATA(N,M) - AV(M))
	  ENDDO
	ENDDO
C
C	PRINT*,' WITH AVERAGES REMOVED'
C
C	FORM VARIANCE MATRIX
C
	DO K = 1,3
	  DO M = 1,3
		VMAT(K,M) = 0.
	  ENDDO
	ENDDO
C
	DO N = 1,NPT
	  DO K = 1,3
	    DO M = K,3
		VMAT(K,M) = VMAT(K,M) + DATAS(N,K)*DATAS(N,M)
	    ENDDO
	  ENDDO
	ENDDO
c	print*,'diag elems',vmat(1,1),vmat(2,2),vmat(3,3),
c     1	' trace',vmat(1,1)+vmat(2,2)+vmat(3,3)
C
C	CALCULATE EIGENVALUES AND MATRIX OF EIGENVECTORS
C
	CALL JACOBI(VMAT,3,3,EVAL,EVECT,NROT)
C	PRINT*,'EIGENVALUES',EVAL
C	PRINT*,'EIGENVECTOR'
C	PRINT*,(EVECT(1,I),I=1,3)
C	PRINT*,(EVECT(2,I),I=1,3)
C	PRINT*,(EVECT(3,I),I=1,3)
C
C	SORT IN DESCENDING ORDER OF EIGENVALUES
C
	CALL EIGSRT(EVAL,EVECT,3,3)
C
C
C 	ENFORCE A RIGHT HANDED SYSTEM BY REVERSING THE SMALLEST
C	EIGENVECTOR IF NECESSARY
C
	ADOTBXC = EVECT(1,1)*EVECT(2,2)*EVECT(3,3)
     1	 - EVECT(1,1)*EVECT(3,2)*EVECT(2,3)
     1	 + EVECT(2,1)*EVECT(1,3)*EVECT(3,2)
     1	 - EVECT(2,1)*EVECT(1,2)*EVECT(3,3)
     1	 + EVECT(3,1)*EVECT(1,2)*EVECT(2,3)
     1	 - EVECT(3,1)*EVECT(2,2)*EVECT(1,3)
C	PRINT*,'DETERMINANT OF EIGENVECTORS',ADOTBXC
	IF(ADOTBXC.LT.0.) THEN        ! REVERSE SMALLEST EVECT FOR RH SYSTEM
	  EVECT(1,3) = -EVECT(1,3)
	  EVECT(2,3) = -EVECT(2,3)
	  EVECT(3,3) = -EVECT(3,3)
C	  PRINT*,'CHANGE TO RIGHT HANDED SYSTEM'
	ENDIF
C
C	PRINT*,'IN SYSTEM',NSYS,'  EIGENVALUES:'
C	PRINT*,EVAL,'eig sum',eval(1)+eval(2)+eval(3)
C	PRINT*,'EIGENVECTORS'
C	PRINT*,(EVECT(1,I),I=1,3)
C	PRINT*,(EVECT(2,I),I=1,3)
C	PRINT*,(EVECT(3,I),I=1,3)
C	WRITE(79,*) 'IN SYSTEM',NSYS,'  EIGENVALUES:'
C	WRITE(79,*)  EVAL
C	WRITE(79,*) 'EIGENVECTORS IN COLUMNS BELOW EIGENVALUES'
C	WRITE(79,*)(EVECT(1,I),I=1,3)
C	WRITE(79,*)(EVECT(2,I),I=1,3)
C	WRITE(79,*)(EVECT(3,I),I=1,3)
	NSYS = 2
	RETURN
	END


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Clausen function \f$\operatorname{Cl}_3(\theta) = \operatorname{Re}(\operatorname{Li}_3(e^{i\theta}))\f$
!> @param x real angle
!> @return \f$\operatorname{Cl}_3(\theta)\f$
!> @author Alexander Voigt
!> Implemented as rational function approximation.
!*********************************************************************

double precision function dcl3(x)
  implicit none
  double precision :: x, y, z, z2, z4, p, q, p0, p1, h
  double precision, parameter :: PI = 3.14159265358979324D0
  double precision, parameter :: PI2 = 2*PI, PIH = PI/2, PI28 = PI*PI/8
  double precision, parameter :: zeta3 = 1.2020569031595943D0
  double precision, parameter :: cp(4) = (/ &
     -7.5000000000000001D-1,                &
      1.5707637881835541D-2,                &
     -3.5426736843494423D-5,                &
     -2.4408931585123682D-7                 /)
  double precision, parameter :: cq(4) = (/ &
      1.0000000000000000D+0,                &
     -2.5573146805410089D-2,                &
      1.5019774853075050D-4,                &
     -1.0648552418111624D-7                 /)
  double precision, parameter :: cr(6) = (/ &
     -4.9017024647634973D-1,                &
      4.1559155224660940D-1,                &
     -7.9425531417806701D-2,                &
      5.9420152260602943D-3,                &
     -1.8302227163540190D-4,                &
      1.8027408929418533D-6                 /)
  double precision, parameter :: cs(6) = (/ &
      1.0000000000000000D+0,                &
     -1.9495887541644712D-1,                &
      1.2059410236484074D-2,                &
     -2.5235889467301620D-4,                &
      1.0199322763377861D-6,                &
      1.9612106499469264D-9                 /)

  if (x .lt. 0) then
     x = -x
  endif

  if (x .ge. PI2) then
     x = mod(x, PI2)
  endif

  if (x .gt. PI) then
     p0 = 6.28125D0
     p1 = 0.0019353071795864769253D0
     x = (p0 - x) + p1
  endif

  if (x .eq. 0) then
     dcl3 = zeta3
     return
  endif

  if (x .lt. PIH) then
    y = x*x
    z = y*y
    p = cp(1) + y * cp(2) + z * (cp(3) + y * cp(4))
    q = cq(1) + y * cq(2) + z * (cq(3) + y * cq(4))
    h = zeta3 + y*(p/q + log(x)/2)
  else
    y = PI - x
    z = y*y - PI28
    z2 = z*z
    z4 = z2*z2
    p = cr(1) + z * cr(2) + z2 * (cr(3) + z * cr(4)) + &
        z4 * (cr(5) + z * cr(6))
    q = cs(1) + z * cs(2) + z2 * (cs(3) + z * cs(4)) + &
        z4 * (cs(5) + z * cs(6))
    h = p/q
  endif

  dcl3 = h

end function dcl3


subroutine UCalcEdgeCenterCoordinate(UG)
    use StructVar_Mod
    use LoopVar_Mod
    implicit none
    type(UnstructuredGrid), intent(inout) :: UG

    iELM => iElement
    call GravityCenterOfTriangle
    call MidPointOfLine

return
contains
!_________________________________________________
    subroutine GravityCenterOfTriangle
    implicit none
        do iElement=1,UG%Tri%Total
            iVertex1 = UG%Tri%Point(iELM,1) !三角形の頂点の点番号
            iVertex2 = UG%Tri%Point(iELM,2)
            iVertex3 = UG%Tri%Point(iELM,3)
            !重心
            UG%CD%Cell(iELM,:) = (UG%CD%Point(iVertex1,:) + UG%CD%Point(iVertex2,:) &
                                        &  + UG%CD%Point(iVertex3,:))/3.0d0
        end do
    return
    end subroutine GravityCenterOfTriangle

!_________________________________________________

    subroutine MidPointOfLine
    implicit none
        do iElement=1, UG%Line%Total
            iEndPoint1 = UG%Line%Point(iELM,1)
            iEndPoint2 = UG%Line%Point(iELM,2)
            UG%CD%Edge(iELM,:) = 0.5d0*(UG%CD%Point(iEndPoint1,:)+UG%CD%Point(iEndPoint2,:))
        end do
    return
    end subroutine MidPointOfLine

end subroutine UCalcEdgeCenterCoordinate


        SUBROUTINE ZCLINT(NX,X,Y,NXOUT,XOUT,YOUT)
*
*  Module number:
*
*  Module name: ZCLINT
*
*  Keyphrase:
*  ----------
*	Linear interpolation
*
*  Description:
*  ------------
*	This routine preforms linear interpolation within
*	input vectors X and Y at positions in vector XTAB.
*
*  FORTRAN name: zclint
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*	none
*
*  Subroutines Called:
*  -------------------
*	none
*
*  History:
*  --------
*  Version      Date        Author          Description
*	1	May 89	D. Lindler	Designed and coded
*-------------------------------------------------------------------------------
*
* INPUTS:
*
*	NX - number of points in input X and Y table
*	X - x-positions in input table
*	Y - y-positions in input table
*	NXOUT - number of points to interpolate
*	XOUT - points to interpolate
*
* OUTPUTS:
*	YOUT - interpolated values
*
*------------------------------------------------------------------------------
        REAL X(1),XOUT(1)
        REAL Y(1),YOUT(1)
C
C Local variables
C
        INTEGER NX,NXOUT
        INTEGER IPOS
C                                    ---> CURRENT POSITION IN X ARRAY
        INTEGER I,II
C                                    ---> INDEX IN XOUT AND YOUT
        REAL FRAC
C                                 ---> FRACTIONAL DISTANCE BETWEEN X(IPOS) AND
C                                       X(IPOS+1) OR XOUT(I)
C-------------------------------------------------------------------------------
C
C INITIALIZATION
C
        IPOS=1
C                                    ---> START AT BEGGINING OF X,Y
C LOOP ON VALUES IN XOUT
C
        DO 100 I=1,NXOUT
C
C FIND  IPOS SUCH THAT X(IPOS) <= XOUT(I) < X(IPOS+1)
C
C DETERMINE IF WE SHOULD DECREASE IPOS
C
           DO 10 II=1,NX
                IF((IPOS.EQ.1).OR.(XOUT(I).GT.X(IPOS)))GO TO 20
                IPOS=IPOS-1
10         CONTINUE
C
C DETERMINE IF WE SHOULD INCREASE IPOS
C
20         DO 30 II=1,NX
                IF((IPOS.EQ.(NX-1)).OR.(XOUT(I).LE.X(IPOS+1))) GO TO 40
                IPOS=IPOS+1
30         CONTINUE
C
C DETERMINE FRACTIONAL DISTANCE BETWEEN X(IPOS) AND X(IPOS+1)
C
40         IF (X(IPOS) .EQ. X(IPOS+1)) THEN
                FRAC=0.0
             ELSE
                FRAC= (XOUT(I)-X(IPOS)) / (X(IPOS+1)-X(IPOS))
             ENDIF
C
C COMPUTE INTERPOLATED VALUE
C
           YOUT(I) = Y(IPOS) + FRAC * (Y(IPOS+1)-Y(IPOS))
100     CONTINUE
        RETURN
        END


program test

use mo_kind,              only: i4, sp, dp
use mo_ansi_colors,       only: color, c_red, c_green
use mo_laplace_inversion, only: NLInvSteh
use mo_utils,             only: eq

implicit none

integer(i4)             :: n,m
real(dp), dimension(10) :: test_s, comp_func1, comp_func2
real(dp), dimension(10) :: testpara, compvalue
real(dp), dimension(10) :: meansq_err

real(sp), dimension(10) :: test_s_sp, comp_func1_sp, comp_func2_sp
real(sp), dimension(10) :: testpara_sp, compvalue_sp
real(sp), dimension(6)  :: meansq_err_sp

LOGICAL                 :: isgood

real(sp)                :: stmp
real(dp)                :: dtmp

!--------------------------------------------------------------------------------------------------
! with testpara[_sp] you can choose one of the served functions:
!       function 1 [ 1/(s+1)    ]   : (2,0,0,0,0,...)
!       function 2 [ 1/(s^2)    ]   : (0,2,0,0,0,...)
!       function 3 [24/(s^5)    ]   : (0,0,2,0,0,...)
!       function 4 [ 1/(s^2 + 1)]   : (0,0,0,2,0,...)
!--------------------------------------------------------------------------------------------------

!--------------------------------------------------------------------------------------------------
!Interface for the test-functions
!--------------------------------------------------------------------------------------------------

INTERFACE
    function testfuncvec(s, para)
        use mo_kind, only: dp
        implicit none
        real(dp), dimension(:), intent(in) :: s
        real(dp), dimension(:), intent(in) :: para
        real(dp), dimension(size(s))       :: testfuncvec
    end function testfuncvec
END INTERFACE

INTERFACE
    function testfuncsgl(s, para)
        use mo_kind, only: dp
        implicit none
        real(dp),               intent(in) :: s
        real(dp), dimension(:), intent(in) :: para
        real(dp)                           :: testfuncsgl
    end function testfuncsgl
END INTERFACE

INTERFACE
    function testfuncvecsp(s, para)
        use mo_kind, only: sp
        implicit none
        real(sp), dimension(:), intent(in) :: s
        real(sp), dimension(:), intent(in) :: para
        real(sp), dimension(size(s))       :: testfuncvecsp
    end function testfuncvecsp
END INTERFACE

INTERFACE
    function testfuncsglsp(s, para)
        use mo_kind, only: sp
        implicit none
        real(sp),               intent(in) :: s
        real(sp), dimension(:), intent(in) :: para
        real(sp)                           :: testfuncsglsp
    end function testfuncsglsp
END INTERFACE

do n=1_i4, size(test_s)
    test_s(n)   =   real(n,dp)!*0.1_dp
end do
do n=1_i4, size(test_s_sp)
    test_s_sp(n)=   real(n,sp)!*0.1_sp
end do

isgood          =   .true.

!--------------------------------------------------------------------------------------------------
! 1. function
!--------------------------------------------------------------------------------------------------

!-------
! dp
!-------

compvalue   =   (/&
  0.36786938930120000_dp,&
  0.13539293114857939_dp,&
   4.9877996513226830E-002_dp,&
   1.8286058932031109E-002_dp,&
   6.5874045566482612E-003_dp,&
   2.2951255530484788E-003_dp,&
   7.6967353312535096E-004_dp,&
   2.6597684820688181E-004_dp,&
   1.2496193720515686E-004_dp,&
   1.0067495791304415E-004_dp/)

! write(*,*) compvalue(10)

testpara=(/2.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp/)

comp_func1=exp(-test_s(:))
comp_func2=NLInvSteh(testfuncvec, testpara, test_s, 12)

write (*,*) " "
write (*,*) " "
write (*,*) "dp: Function 1/(s+1) with inverse function e^(-t) [Stehfest-limit=12]"
write (*,*) '-------------------------------------------------------------------------------------------'
write (*,*) "time t                     analytical inverse        Stehfest-inverted        relativ error"
write (*,*) '-------------------------------------------------------------------------------------------'
do n=1_i4,size(test_s)
    write (*,*) test_s(n), comp_func1(n), comp_func2(n), abs((comp_func2(n)-comp_func1(n))/comp_func1(n))
    dtmp = NLInvSteh(testfuncsgl, testpara, test_s(n), 12)
    isgood = isgood .and. eq(comp_func2(n), dtmp)
    isgood = isgood .and. (int((comp_func2(n)-compvalue(n))*1000000.0_dp, i4) .eq. 0_i4)
end do

meansq_err=0.0_dp
do m=1_i4, size(meansq_err)
   ! write (*,*) " "
   ! write (*,*) "stehfest-limit: ", 2*m
   comp_func2=NLInvSteh(testfuncvec, testpara, test_s,2*m)
   ! write (*,*) " "
   ! write (*,*) "Function 1/(s+1) with inverse function e^(-t)"
   ! write (*,*) '-------------------------------------------------------------------------------------------'
   ! write (*,*) "time t                     analytical inverse        Stehfest-inverted        relativ error"
   ! write (*,*) '-------------------------------------------------------------------------------------------'
   do n=1_i4,size(test_s)
      ! write (*,*) test_s(n), comp_func1(n), comp_func2(n), abs((comp_func2(n)-comp_func1(n))/comp_func1(n))
      meansq_err(m)=meansq_err(m)+(comp_func2(n)-comp_func1(n))**2
   end do
end do

write (*,*) " "
write (*,*) "MSE between the stehfest-inverted- and analytical-function in dependency of the stehfestlimit"
write (*,*) '---------------------------------------------------------------------------------------------'
do m=1_i4, size(meansq_err)
    write (*,*) "stehfest-limit with MSE: ", 2*m,":", meansq_err(m)
end do
write (*,*) "least absolut MSE with Stehfest-limit: ", minloc(meansq_err)*2

!-------
! sp
!-------

compvalue_sp   =   (/&
    0.262637794_sp,&
    0.138087913_sp,&
    1.62456371E-02_sp,&
    6.90439567E-02_sp,&
    6.49825484E-03_sp,&
    -3.61014158E-03_sp,&
    -2.93968674E-02_sp,&
    2.30146535E-02_sp,&
    4.81352210E-03_sp,&
    4.22386564E-02_sp/)

testpara_sp=(/2.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp/)

comp_func1_sp=exp(-test_s_sp(:))
comp_func2_sp=NLInvSteh(testfuncvecsp, testpara_sp, test_s_sp, 12_i4)

write (*,*) " "
write (*,*) "sp: Function 1/(s+1) with inverse function e^(-t) [Stehfest-limit=12]"
write (*,*) '---------------------------------------------------------------------'
write (*,*) "time t         analytical inverse  Stehfest-inverted   relativ error"
write (*,*) '--------------------------------------------------------------------'
do n=1_i4,size(test_s_sp)
   write (*,*) test_s_sp(n), comp_func1_sp(n), comp_func2_sp(n), abs((comp_func2_sp(n)-comp_func1_sp(n))/comp_func1_sp(n))
   stmp = NLInvSteh(testfuncsglsp, testpara_sp, test_s_sp(n), 12)
   isgood = isgood .and. eq(comp_func2_sp(n), stmp)
   isgood = isgood .and. (int((comp_func2_sp(n)-compvalue_sp(n))*1000.0_sp, i4) .eq. 0_i4)
end do

meansq_err_sp=0.0_sp
do m=1_i4, size(meansq_err_sp)
   ! write (*,*) " "
   ! write (*,*) "stehfest-limit: ", 2*m
   comp_func2_sp=NLInvSteh(testfuncvecsp, testpara_sp, test_s_sp,2*m)
   ! write (*,*) " "
   ! write (*,*) "Function 1/(s+1) with inverse function e^(-t)"
   ! write (*,*) '-------------------------------------------------------------------'
   ! write (*,*) "time t        analytical inverse  Stehfest-inverted   relativ error"
   ! write (*,*) '-------------------------------------------------------------------'
    do n=1_i4,size(test_s_sp)
       ! write (*,*) test_s_sp(n), comp_func1_sp(n), comp_func2_sp(n), abs((comp_func2_sp(n)-comp_func1_sp(n))/comp_func1_sp(n))
       meansq_err_sp(m)=meansq_err_sp(m)+(comp_func2_sp(n)-comp_func1_sp(n))**2
    end do
end do

write (*,*) " "
write (*,*) "MSE between the stehfest-inverted- and analytical-function in dependency of the stehfestlimit"
write (*,*) '---------------------------------------------------------------------------------------------'
do m=1_i4, size(meansq_err_sp)
    write (*,*) "stehfest-limit with MSE: ", 2*m,":", meansq_err_sp(m)
end do
write (*,*) "least absolut MSE with Stehfest-limit: ", minloc(meansq_err_sp)*2

!--------------------------------------------------------------------------------------------------
! 2. function
!--------------------------------------------------------------------------------------------------

!-------
! dp
!-------

compvalue   =   (/&
   1.0000009622103812_dp,&
   2.0000019244207623_dp,&
   3.0000028866118105_dp,&
   4.0000038488415246_dp,&
   5.0000048109464998_dp,&
   6.0000057732236209_dp,&
   7.0000067358527165_dp,&
   8.0000076976830492_dp,&
   9.0000086601285041_dp,&
   10.000009621893000_dp/)

testpara=(/0.0_dp,2.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp/)

comp_func1=test_s
comp_func2=NLInvSteh(testfuncvec, testpara, test_s, 12)

write (*,*) " "
write (*,*) " "
write(*,*) "dp: function 1/(s^2) with inverse function t [Stehfest-limit=12]"
write (*,*) '-------------------------------------------------------------------------------------------'
write (*,*) "time t                     analytical inverse        Stehfest-inverted        relativ error"
write (*,*) '-------------------------------------------------------------------------------------------'
do n=1_i4,size(test_s)
    write (*,*) test_s(n), comp_func1(n), comp_func2(n), abs((comp_func2(n)-comp_func1(n))/comp_func1(n))
    dtmp = NLInvSteh(testfuncsgl, testpara, test_s(n), 12)
    isgood = isgood .and. eq(comp_func2(n), dtmp)
    isgood = isgood .and. (int((comp_func2(n)-compvalue(n))*1000000.0_dp, i4) .eq. 0_i4)
end do

!-------
! sp
!-------

compvalue_sp   =   (/&
    1.00012207_sp,&
    2.00024414_sp,&
    3.00002766_sp,&
    4.00048828_sp,&
    5.02748299_sp,&
    6.00005531_sp,&
    6.81852579_sp,&
    8.00097656_sp,&
    9.01331997_sp,&
    10.0549660_sp/)

testpara_sp=(/0.0_sp,2.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp/)

comp_func1_sp=test_s_sp
comp_func2_sp=NLInvSteh(testfuncvecsp, testpara_sp, test_s_sp, 12)

write (*,*) " "
write(*,*) "sp: function 1/(s^2) with inverse function t [Stehfest-limit=12]"
write (*,*) '--------------------------------------------------------------------'
write (*,*) "time t         analytical inverse  Stehfest-inverted   relativ error"
write (*,*) '--------------------------------------------------------------------'
do n=1_i4,size(test_s_sp)
    write (*,*) test_s_sp(n), comp_func1_sp(n), comp_func2_sp(n), abs((comp_func2_sp(n)-comp_func1_sp(n))/comp_func1_sp(n))
    stmp = NLInvSteh(testfuncsglsp, testpara_sp, test_s_sp(n), 12)
    isgood = isgood .and. eq(comp_func2_sp(n), stmp)
    isgood = isgood .and. (int((comp_func2_sp(n)-compvalue_sp(n))*1000.0_sp, i4) .eq. 0_i4)
end do

!!--------------------------------------------------------------------------------------------------
!! 3. function makes --> problems with different compiliers
!!--------------------------------------------------------------------------------------------------

!!-------
!! dp
!!-------

!compvalue   =   (/&
!   1.0072917132281780_dp,&
!   16.116667411650848_dp,&
!   81.590628772012082_dp,&
!   257.86667858641357_dp,&
!   629.55732075484286_dp,&
!   1305.4500603521933_dp,&
!   2418.5074034629538_dp,&
!   4125.8668573826171_dp,&
!   6608.8409304767702_dp,&
!   10072.917132077486_dp/)

!testpara=(/0.0_dp,0.0_dp,2.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp/)

!comp_func1=test_s(:)**4_i4
!comp_func2=NLInvSteh(testfuncvec, testpara, test_s, 12)

!write (*,*) " "
!write (*,*) " "
!write (*,*) "dp: function 24/(s^5) with inverse function t^4 [Stehfest-limit=12]"
!write (*,*) '----------------------------------------------------------------------------------------------------------------------'
!write (*,*) "time t                     analytical inverse        Stehfest-inverted        relativ error"
!write (*,*) '-------------------------------------------------------------------------------------------------------'
!do n=1_i4,size(test_s)
!    write (*,*) test_s(n), comp_func1(n), comp_func2(n), abs((comp_func2(n)-comp_func1(n))/comp_func1(n))

!    isgood = isgood .and. eq(comp_func2(n),NLInvSteh(testfuncsgl, testpara, test_s(n), 12))
!    isgood = isgood .and. (int((comp_func2(n)-compvalue(n))*1000000.0_dp, i4) .eq. 0_i4)
!end do

!!-------
!! sp
!!-------

!compvalue_sp   =   (/&
!    1.01060343_sp,&
!    16.1696548_sp,&
!    81.7020187_sp,&
!    258.714478_sp,&
!    625.435364_sp,&
!    1307.23230_sp,&
!    2387.24829_sp,&
!    4139.43164_sp,&
!    6627.02637_sp,&
!    10006.9658_sp/)

!testpara_sp=(/0.0_sp,0.0_sp,2.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp/)

!comp_func1_sp=test_s_sp(:)**4_i4
!comp_func2_sp=NLInvSteh(testfuncvecsp, testpara_sp, test_s_sp, 12)

!write (*,*) " "
!write (*,*) "sp: function 24/(s^5) with inverse function t^4 [Stehfest-limit=12]"
!write (*,*) '----------------------------------------------------------------------------------------------------------------------'
!write (*,*) "time t         analytical inverse  Stehfest-inverted   relativ error"
!write (*,*) '-------------------------------------------------------------------------------------------------------'
!do n=1_i4,size(test_s_sp)
!    write (*,*) test_s_sp(n), comp_func1_sp(n), comp_func2_sp(n), abs((comp_func2_sp(n)-comp_func1_sp(n))/comp_func1_sp(n))

!    isgood = isgood .and. eq(comp_func2_sp(n),NLInvSteh(testfuncsglsp, testpara_sp, test_s_sp(n), 12))
!    isgood = isgood .and. (int((comp_func2_sp(n)-compvalue_sp(n))*1000.0_sp, i4) .eq. 0_i4)
!end do

!--------------------------------------------------------------------------------------------------
! 4. function
!--------------------------------------------------------------------------------------------------

!-------
! dp
!-------

compvalue   =   (/&
  0.83959871008261233_dp,&
  0.94458688164622640_dp,&
  3.2028647167191657E-002_dp,&
 -0.82004733974486821_dp,&
 -0.55999021955903139_dp,&
 -2.2709467812679900E-002_dp,&
  0.22006692791712928_dp,&
  0.21684512943141837_dp,&
  0.13265657517960888_dp,&
  5.5232344654943893E-002_dp/)

testpara=(/0.0_dp,0.0_dp,0.0_dp,2.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp/)

comp_func1=sin(test_s(:))
comp_func2=NLInvSteh(testfuncvec, testpara, test_s, 12)

write (*,*) " "
write (*,*) " "
write (*,*) "dp: function 1/(s^2 + 1) with inverse function sin(t) [Stehfest-limit=12]"
write (*,*) '-------------------------------------------------------------------------------------------'
write (*,*) "time t                     analytical inverse        Stehfest-inverted        relativ error"
write (*,*) '-------------------------------------------------------------------------------------------'
do n=1_i4,size(test_s)
    write (*,*) test_s(n), comp_func1(n), comp_func2(n), abs((comp_func2(n)-comp_func1(n))/comp_func1(n))
    dtmp = NLInvSteh(testfuncsgl, testpara, test_s(n), 12)
    isgood = isgood .and. eq(comp_func2(n), dtmp)
    isgood = isgood .and. (int((comp_func2(n)-compvalue(n))*1000000.0_dp, i4) .eq. 0_i4)
end do

meansq_err=0.0_dp
do m=1_i4, size(meansq_err)
   ! write (*,*) " "
   ! write (*,*) "stehfest-limit: ", 2*m
   comp_func2=NLInvSteh(testfuncvec, testpara, test_s, 2*m)
   ! write (*,*) " "
   ! write (*,*) "function 1/(s^2 + 1) with inverse function sin(t)"
   ! write (*,*) '-------------------------------------------------------------------------------------------'
   ! write (*,*) "time t                     analytical inverse        Stehfest-inverted        relativ error"
   ! write (*,*) '-------------------------------------------------------------------------------------------'
   do n=1_i4,size(test_s)
      ! write (*,*) test_s(n), comp_func1(n), comp_func2(n), abs((comp_func2(n)-comp_func1(n))/comp_func1(n))
      meansq_err(m)=meansq_err(m)+(comp_func2(n)-comp_func1(n))**2
   end do
end do

write (*,*) " "
write (*,*) "MSE between the stehfest-inverted- and analytical-function in dependency of the stehfestlimit"
write (*,*) '---------------------------------------------------------------------------------------------'
do m=1_i4,size(meansq_err)
    write (*,*) "stehfest-limit with MSE: ", 2*m,":", meansq_err(m)
end do
write (*,*) "least absolut MSE with Stehfest-limit: ", minloc(meansq_err)*2
write (*,*) ' '

!-------
! sp
!-------

compvalue_sp   =   (/&
    0.840711713_sp,&
    0.959169507_sp,&
    6.67876154E-02_sp,&
    -0.852895975_sp,&
    -0.582676828_sp,&
    6.31774813E-02_sp,&
    0.236722142_sp,&
    0.222023711_sp,&
    0.134778619_sp,&
    6.28164634E-02_sp/)

testpara_sp=(/0.0_sp,0.0_sp,0.0_sp,2.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp,0.0_sp/)

comp_func1_sp=sin(test_s_sp(:))
comp_func2_sp=NLInvSteh(testfuncvecsp, testpara_sp, test_s_sp, 12)

write (*,*) " "
write (*,*) " "
write (*,*) "sp: function 1/(s^2 + 1) with inverse function sin(t) [Stehfest-limit=12]"
write (*,*) '-------------------------------------------------------------------------'
write (*,*) "time t         analytical inverse  Stehfest-inverted   relativ error"
write (*,*) '-------------------------------------------------------------------------'
do n=1_i4,size(test_s_sp)
    write (*,*) test_s_sp(n), comp_func1_sp(n), comp_func2_sp(n), abs((comp_func2_sp(n)-comp_func1_sp(n))/comp_func1_sp(n))
    stmp = NLInvSteh(testfuncsglsp, testpara_sp, test_s_sp(n), 12)
    isgood = isgood .and. eq(comp_func2_sp(n), stmp)
#ifdef __INTEL__
    !MC Intel work around hopefully temporary
    isgood = isgood .and. (int((comp_func2_sp(n)-compvalue_sp(n))*10.0_sp, i4) .eq. 0_i4)
#else
    isgood = isgood .and. (int((comp_func2_sp(n)-compvalue_sp(n))*1000.0_sp, i4) .eq. 0_i4)
#endif
end do

meansq_err_sp=0.0_sp
do m=1_i4, size(meansq_err_sp)
   ! write (*,*) " "
   ! write (*,*) "stehfest-limit: ", 2*m
   comp_func2_sp=NLInvSteh(testfuncvecsp, testpara_sp, test_s_sp, 2*m)
   ! write (*,*) " "
   ! write (*,*) "function 1/(s^2 + 1) with inverse function sin(t)"
   ! write (*,*) '-------------------------------------------------------------------------------------------'
   ! write (*,*) "time t                     analytical inverse        Stehfest-inverted        relativ error"
   ! write (*,*) '-------------------------------------------------------------------------------------------'
    do n=1_i4,size(test_s_sp)
       ! write (*,*) test_s_sp(n), comp_func1_sp(n), comp_func2_sp(n), abs((comp_func2_sp(n)-comp_func1_sp(n))/comp_func1_sp(n))
       meansq_err_sp(m)=meansq_err_sp(m)+(comp_func2_sp(n)-comp_func1_sp(n))**2
    end do
end do

write (*,*) " "
write (*,*) "MSE between the stehfest-inverted- and analytical-function in dependency of the stehfestlimit"
write (*,*) '---------------------------------------------------------------------------------------------'
do m=1_i4, size(meansq_err_sp)
    write (*,*) "stehfest-limit with MSE: ", 2*m,":", meansq_err_sp(m)
end do
write (*,*) "least absolut MSE with Stehfest-limit: ", minloc(meansq_err_sp)*2
write (*,*) ' '

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

write (*,*) '-------------------------------------------------------------------------'
write (*,*) '-------------------------------------------------------------------------'
write (*,*) ' '
if (isgood) then
    write(*,*) 'mo_laplace_inversion ', color('o.k.', c_green)
else
    write(*,*) 'mo_laplace_inversion ', color('failed', c_red)
endif

end program test

function testfuncvec(s, para)
    use mo_kind, only: i4, dp
    implicit none
    real(dp), dimension(:), intent(in) :: s
    real(dp), dimension(:), intent(in) :: para
    real(dp), dimension(size(s))       :: testfuncvec

    testfuncvec =   0.0_dp

    if (para(1)>1) testfuncvec=1.0_dp/(s(:) + 1.0_dp)
    if (para(2)>1) testfuncvec=1.0_dp/(s(:)**2_i4)
    if (para(3)>1) testfuncvec=24.0_dp/(s(:)**5_i4)
    if (para(4)>1) testfuncvec=1.0_dp/(s(:)**2_i4 +1.0_dp)

end function testfuncvec

function testfuncsgl(s, para)
    use mo_kind, only: i4, dp
    implicit none
    real(dp),               intent(in) :: s
    real(dp), dimension(:), intent(in) :: para
    real(dp)                           :: testfuncsgl

    testfuncsgl =   0.0_dp

    if (para(1)>1) testfuncsgl=1.0_dp/(s + 1.0_dp)
    if (para(2)>1) testfuncsgl=1.0_dp/(s**2_i4)
    if (para(3)>1) testfuncsgl=24.0_dp/(s**5_i4)
    if (para(4)>1) testfuncsgl=1.0_dp/(s**2_i4 +1.0_dp)

end function testfuncsgl

function testfuncvecsp(s, para)
    use mo_kind, only: i4, sp
    implicit none
    real(sp), dimension(:), intent(in) :: s
    real(sp), dimension(:), intent(in) :: para
    real(sp), dimension(size(s))       :: testfuncvecsp

    testfuncvecsp =   0.0_sp

    if (para(1)>1) testfuncvecsp=1.0_sp/(s(:) + 1.0_sp)
    if (para(2)>1) testfuncvecsp=1.0_sp/(s(:)**2_i4)
    if (para(3)>1) testfuncvecsp=24.0_sp/(s(:)**5_i4)
    if (para(4)>1) testfuncvecsp=1.0_sp/(s(:)**2_i4 +1.0_sp)

end function testfuncvecsp

function testfuncsglsp(s, para)
    use mo_kind, only: i4, sp
    implicit none
    real(sp),               intent(in) :: s
    real(sp), dimension(:), intent(in) :: para
    real(sp)                           :: testfuncsglsp

    testfuncsglsp =   0.0_sp

    if (para(1)>1) testfuncsglsp=1.0_sp/(s + 1.0_sp)
    if (para(2)>1) testfuncsglsp=1.0_sp/(s**2_i4)
    if (para(3)>1) testfuncsglsp=24.0_sp/(s**5_i4)
    if (para(4)>1) testfuncsglsp=1.0_sp/(s**2_i4 +1.0_sp)

end function testfuncsglsp


module mod

contains
  real function add(x, y)
    real :: x
    real :: y
    real :: z
    z = 0.1
    add = x + y + z
  end function add
end module mod

program t

    use mod
    real :: r
    r = add(10.55, 5.1010)
    print *,  r

end program t


program blockmatrix
    implicit none
    integer, dimension(:,:), codimension[:,:], allocatable :: a, b, c
    integer, dimension(:,:), allocatable :: bigmat
    integer :: numimgs
    integer :: nrows, ncols
    integer :: blockrows=5, blockcols=5
    integer :: myrow, mycol
    integer :: startrow, startcol
    integer :: i,j,k

    ! calculate block decomposition
    numimgs = num_images()
    call nearsquare(numimgs, nrows, ncols)
    if (nrows /= ncols) then
        print *,'Sorry, only works for square numbers of images right now.'
        stop
    endif
    allocate(a(blockrows,blockcols)[nrows,*])
    allocate(b(blockcols,blockrows)[nrows,*])
    allocate(c(blockrows,blockrows)[nrows,*])

    ! where is this image in the decomposition?
    mycol = ceiling(this_image()*1./nrows)
    myrow = modulo(this_image(),nrows)
    if (myrow == 0) myrow=nrows

    ! initialize data
    startrow = (myrow-1)*blockrows+1
    startcol = (mycol-1)*blockcols+1
    do i=1,blockrows
        a(i,:) = startrow+i-1
    enddo
    do j=1,blockcols
        b(:,j) = startcol+j-1
    enddo

    ! do the multiplication
    sync all
    c = 0.
    do k=1,ncols
        c = c + matmul(a(:,:)[myrow,k],b(:,:)[k,mycol])
    enddo
    sync all

    if (this_image() == 1) then
        allocate(bigmat(nrows*blockrows,ncols*blockcols))
        bigmat = reshape( [((i,i=1,nrows*blockrows),j=1,ncols*blockcols)], &
                          [nrows*blockrows, ncols*blockcols])
        print *, 'Expected answer: '
        bigmat = matmul(bigmat,transpose(bigmat))
        do i=1,blockrows*nrows
             print '(50(I5,1X))',(bigmat(i,j),j=1,blockcols*ncols)
        enddo
        deallocate(bigmat)
    endif

    do k=1,num_images()
        if (this_image() == k) then
            print *, 'Image ', k, ' = ', myrow, ', ', mycol
            do i=1,blockrows
                 print '(50(I5,1X))',(c(i,j),j=1,blockcols)
            enddo
        endif
        sync all
    enddo
    deallocate(a)
    deallocate(b)
    deallocate(c)

contains
    subroutine nearsquare(n, a, b)
        implicit none
        integer, intent(in) :: n
        integer, intent(out) :: a, b

        do a=ceiling(sqrt(n*1.0)),1,-1
            b = n/a
            if (a*b == n) exit
        enddo
    end subroutine nearsquare

end program blockmatrix


! Mikayla Webber
! 4670 Numerical Analysis
! Homework G Due 12.1.17

! use at least three numerical methods to solve:
! dy/dt = te^(3t) - 2y
! y(0) = 0
! for 0 <= t <= 2
! for each method obtain at least 100 data points on your approximation and produce a graph for each method.

program aopc
  implicit none

  integer :: i, neq, nsteps
  double precision :: a, b, dt
  double precision, allocatable, dimension(:, :) :: archive
  double precision, allocatable, dimension(:) :: f, t, u, f1, fi, fim1, fim2, fim3, fim4, yin, yout

  neq = 1
  a = 0.0d0
  b = 2.0d0
  nsteps = 100

  allocate(yin(neq), yout(neq), u(neq), t(0:nsteps), f(neq), archive(neq,0:nsteps))
  allocate(fi(neq), fim1(neq), fim2(neq), fim3(neq), fim4(neq))

  dt = ((b - a) / dble(nsteps))

  do i = 0, nsteps
    t(i) = (a + dble(i) * dt)
  end do

  archive (:,0) = (/ 1.0d0, 0.0d0, 0.0d0, 1.0d0 /) ! initial state vector
  call abinitializer(neq, nsteps, t, archive)

  do i = 4, (nsteps - 1)
    call computef(neq, t(i), archive(:,i), fi)
    call computef(neq, t(i-1), archive(:,i-1), fim1)
    call computef(neq, t(i-2), archive(:,i-2), fim2)
    call computef(neq, t(i-3), archive(:,i-3), fim3)
    call computef(neq, t(i-4), archive(:,i-4), fim4)
    u = archive(:,i) + dt / 720.0d0 * (1901.0d0 * fi - 2774.0d0 * fim1 + 2616.0d0 * fim2 - 1274.0d0 * fim3 + 251.0d0 * fim4)
  end do

  print*, 'Creating "out5.2.3"'
  open(unit=8, file='out5.2.3', status='replace')

  do i = 0, nsteps
    write(8,*) t(i), archive(1,i)
  end do

  close(8)
  deallocate(yin, yout, u, f, t, f1, fi, fim1, fim2, fim3, fim4, archive)

  stop
end program aopc

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

subroutine computef(neq, t, y, f)
  implicit none
  integer :: neq
  double precision :: f(neq)
  double precision, intent(in) :: t, y(neq)
  ! This subroutine computes the RHS of the differential equation:
  !  dy
  !  -- = f(t, y)
  !  dt
  ! where y is the array of unknowns, indexed from one to neq and f is the array of right sides.

  !y(0) = 0
  f(1) = (t * dexp(3.0d0 * t) - 2.0d0 * y(1))

  return
end

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

subroutine abinitializer(neq, nsteps, t, archive)
  implicit none
  integer :: i, nsteps
  integer, intent(in) :: neq
  double precision, intent(in) :: t(0:nsteps)
  double precision :: tin, tout, yin(neq), yout(neq), archive(neq,0:nsteps)

  do i = 0, neq
    tin = t(i)
    yin = archive(:,i)
    tout = t(i+1)
    call extrapolate(neq, tin, tout, yin, yout)
    archive(:,i+1) = yout
  end do

  return
end

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

subroutine extrapolate(neq, tin, tout, yin, yout)
  implicit none

  integer, intent(in) :: neq
  integer :: i, k, nrich, nsteps
  double precision :: yout(neq), bot
  double precision, intent(in) :: tin, tout, yin(neq)
  double precision, allocatable, dimension(:, :, :) :: table

  nrich = 10
  nsteps = 1
  allocate(table(0:nrich, 0:nrich, neq))

  do i = 0, nrich
    call euler(neq, tin, tout, nsteps, yin, yout)
    table(i,0,:) = yout
    nsteps = (nsteps * 2)
  end do

  do k = 1, nrich
    bot = (2.0d0**k - 1.0d0)
    do i = k, nrich
      table(i,k,:) = (table(i,k-1,:) + (table(i,k-1,:) - table(i-1,k-1,:)) / bot)
    end do
  end do

  yout = table(nrich, nrich, :)
  return
end

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

subroutine euler(neq, tin, tout, nsteps, yin, yout)
  implicit none

  integer :: i
  integer, intent(in) :: neq, nsteps
  double precision :: yout(neq), f(neq), dt
  double precision, intent(in) :: tin, tout, yin(neq)

  yout = yin
  dt = ((tout - tin)/dble(nsteps))

  do i = 0, (nsteps - 1)
    call computef(neq, (tin + dble(i) * dt), yout, f)
    yout = (yout + dt * f)
  end do

  return
end


real function add(x, y)
  real :: x
  real :: y
  real :: z
  z = 0.1
  add = x + y + z
end function add

program t

  real :: r
  r = add(10.55, 5.1010)
  print *,  r

end program t


module vector_utils_m
use constants_m
implicit none

contains

function p_norm(v1,p) result(s)
  real(rp),dimension(:),intent(in)::v1
  integer,intent(in)::p
  real(rp)::s
  s=sum(abs(v1)**p)**(one/p)
end function

function vec_mag(v1) result(s)
  real(rp),dimension(:),intent(in)::v1
  real(rp)::s
  s=sqrt(dot_product(v1,v1))
end function

function unit_vec(v1) result(v)
  real(rp),dimension(:),intent(in)::v1
  real(rp),dimension(size(v1))::v
  v=v1/(vec_mag(v1)+small)
end function

function cross_prod(v1,v2) result(v)
  real(rp),dimension(3),intent(in)::v1,v2
  real(rp),dimension(3)::v
  integer,dimension(3),parameter::i1=(/2,3,1/)
  integer,dimension(3),parameter::i2=(/3,1,2/)
  v=v1(i1)*v2(i2)-v2(i1)*v1(i2)
end function

function vvec_mag(v1) result(v)
  real(rp),dimension(:,:),intent(in)::v1
  real(rp),dimension(size(v1,2))::v
  integer::i
  do i=1,size(v)
    v(i)=vec_mag(v1(:,i))
  end do
end function

function rev_order(v1) result(v)
  integer,dimension(:),intent(in)::v1
  integer,dimension(size(v1))::v
  integer::i,j
  j=0
  do i=size(v1),1,-1
    j=j+1
    v(i)=v1(j)
  end do
end function

function first_loc(v1,s1) result(s)
  integer,dimension(:),intent(in)::v1
  integer,intent(in)::s1
  integer::s,i
  s=0
  do i=1,size(v1)
    select case(v1(i)-s1)
    case(0)
      s=i
      return
    end select
  end do
end function

! C
subroutine setcp (n_lst, lst, iset)
  integer,intent(in)::n_lst
  integer,dimension(0:n_lst-1)::lst
  integer,intent(in)::iset

  integer::i, j, jj, k, l

  i = 0;
  do

    do j = i + 1, n_lst - 1
      jj = j;
      if (lst(j) /= lst(i)) then
        exit;
      end if
      if (j == n_lst - 1) jj = jj + 1;
    end do

    j = jj;

    do k = i + 1, j - 1
      lst(k) = iset;
    end do

    i = j;
    if (i >= n_lst - 1) exit;
  end do
end subroutine

! C
subroutine hpsortf (n, ra)
  integer,intent(in)::n
!   integer,dimension(n)::ra
  real(rp),dimension(n)::ra

  integer::l,ir,i,j
!   integer::rra
  real(rp)::rra

  l=n/2+1
  ir=n

10 continue
  if(l > 1)then
    l=l-1
    rra=ra(l)
  else
    rra=ra(ir)
    ra(ir)=ra(1)
    ir=ir-1
    if(ir.eq.1)then
      ra(1)=rra
      return
    end if
  end if
  i=l
  j=l+l

20 if(j.le.ir)then
    if(j < ir)then
      if(ra(j) < ra(j+1))  j=j+1
    end if
    if(rra < ra(j))then
      ra(i)=ra(j)
      i=j; j=j+j
    else
      j=ir+1
    end if
    goto 20
  end if

  ra(i)=rra
  goto 10
end subroutine

! C
subroutine hpsorti (n, ra)
  integer,intent(in)::n
  integer,dimension(n)::ra
!   real(rp),dimension(n)::ra

  integer::l,ir,i,j
  integer::rra
!   real(rp)::rra

  l=n/2+1
  ir=n

10 continue
  if(l > 1)then
    l=l-1
    rra=ra(l)
  else
    rra=ra(ir)
    ra(ir)=ra(1)
    ir=ir-1
    if(ir.eq.1)then
      ra(1)=rra
      return
    end if
  end if
  i=l
  j=l+l

20 if(j.le.ir)then
    if(j < ir)then
      if(ra(j) < ra(j+1))  j=j+1
    end if
    if(rra < ra(j))then
      ra(i)=ra(j)
      i=j; j=j+j
    else
      j=ir+1
    end if
    goto 20
  end if

  ra(i)=rra
  goto 10
end subroutine

! C
subroutine uniq (m0, lst0, m1, lst1)
  integer, intent(in) :: m0
  integer, dimension(:), intent(in) :: lst0
  integer, intent(out) :: m1
  integer, dimension(:), allocatable :: lst1

  integer :: i, int_max

  allocate (lst1(m0))
  lst1 = lst0

  int_max = huge (i)
  call hpsorti (m0, lst1)
  call setcp (m0, lst1, int_max)
  call hpsorti (m0, lst1)

  m1 = 0
  do i = 1, m0
    if (lst1(i) < int_max) m1 = m1 + 1
  end do
end subroutine

subroutine iuniq (m0, lst0)
  integer, intent(inout) :: m0
  integer, dimension(:), intent(inout) :: lst0

  integer :: i, int_max, m1

  int_max = huge (i)

  call hpsorti (m0, lst0)
  call setcp (m0, lst0, int_max)
  call hpsorti (m0, lst0)

  m1 = 0
  do i = 1, m0
    if (lst0(i) < int_max) m1 = m1 + 1
  end do
  m0 = m1
end subroutine
end module


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine straighteq2d(col,straight)
!
!     calculate the equation of the edges of a triangle with
!     (col(1,1),col(2,1)),(col(1,2),col(2,2)),(col(1,3),col(2,3))
!     as vertices. The equation of the edge
!     opposite notet(1) is of the form
!     straight(1)*x+straight(2)*y+straight(3)=0, such that the
!     vector (straight(1),straight(2)) points outwards; for the edge
!     opposite of nodet(2) the equation is
!     straight(4)*x+straight(5)*y+straight(6)=0 and for the edge
!     oppositie of nodet(3) it is
!     straight(7)*x+straight(8)*y+straight(9)=0. Here too, the normals
!     (straight(4),straight(5)) and (straight(7),straight(8)) point
!     outwards of the triangle.
!
      implicit none
!
      real*8 col(2,3),straight(9),x1,y1,dd
!
!     edge opposite of 1
!
      x1=col(1,3)-col(1,2)
      y1=col(2,3)-col(2,2)
      dd=dsqrt(x1*x1+y1*y1)
!
      straight(1)=y1/dd
      straight(2)=-x1/dd
!
      straight(3)=-(straight(1)*col(1,3)+
     &             straight(2)*col(2,3))
!
      if(straight(1)*col(1,1)+straight(2)*col(2,1)+
     &   straight(3).gt.0.d0) then
         straight(1)=-straight(1)
         straight(2)=-straight(2)
         straight(3)=-straight(3)
      endif
!
!     edge opposite of 2
!
      x1=col(1,1)-col(1,3)
      y1=col(2,1)-col(2,3)
      dd=dsqrt(x1*x1+y1*y1)
!
      straight(4)=y1/dd
      straight(5)=-x1/dd
!
      straight(6)=-(straight(4)*col(1,1)+
     &             straight(5)*col(2,1))
!
      if(straight(4)*col(1,2)+straight(5)*col(2,2)+
     &   straight(6).gt.0.d0) then
         straight(4)=-straight(4)
         straight(5)=-straight(5)
         straight(6)=-straight(6)
      endif
!
!     edge opposite of 3
!
      x1=col(1,2)-col(1,1)
      y1=col(2,2)-col(2,1)
      dd=dsqrt(x1*x1+y1*y1)
!
      straight(7)=y1/dd
      straight(8)=-x1/dd
!
      straight(9)=-(straight(7)*col(1,2)+
     &             straight(8)*col(2,2))
!
      if(straight(7)*col(1,3)+straight(8)*col(2,3)+
     &   straight(9).gt.0.d0) then
         straight(7)=-straight(7)
         straight(8)=-straight(8)
         straight(9)=-straight(9)
      endif
!
      return
      end


module mod_condition
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ONE

    use mod_inv,    only: inv

    implicit none

    ! External procedures defined in LAPACK
    external DGETRI
    external DGETRF
    external DGECON
    external DLANGE
    real(rk) :: DLANGE

contains

!    subroutine condition_number(dim1,dim2,mat,rcond)
!        integer(kind=ik), intent(in)                        :: dim1,dim2
!        real(kind=rk),    intent(in), dimension(dim1,dim2)  :: mat
!        real(kind=rk),    intent(inout)                     :: rcond
!
!
!        real(kind=rk)                                   :: mat_norm,invmat_norm
!        integer(kind=ik)                                :: i, info, j, n, idim1,idim2
!        real(kind=rk),      dimension(dim1,dim2)        :: invmat
!        real(kind=rk),      dimension(dim2)             :: vector_sum_mat, vector_sum_invmat
!
!        invmat = inv(mat)
!
!        ! compute the 1-norm of each matrix
!        do idim2 = 1,dim2
!            vector_sum_mat(idim2)    = sum(abs(mat(:,idim2)))
!            vector_sum_invmat(idim2) = sum(abs(invmat(:,idim2)))
!        end do
!
!        mat_norm    = maxval(vector_sum_mat)
!        invmat_norm = maxval(vector_sum_invmat)
!
!        ! compute the matrix condition number
!        rcond = mat_norm*invmat_norm
!
!    end subroutine condition_number
!

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/17/2016
    !!
    !!  TODO: Try to find URL for citation.
    !!
    !---------------------------------------------------------------------------
    function cond(A) result(rcond_out)
        real(rk), dimension(:,:), intent(in) :: A
        real(rk), dimension(size(A,1),size(A,2)) :: Ainv

!        real(rk), dimension(size(A,1)) :: work    ! work array for LAPACK
        real(rk), dimension(size(A,1)) :: nwork
        real(rk), dimension(size(A,1)*4) :: conwork
        integer,  dimension(size(A,1))   :: iconwork
        integer,  dimension(size(A,1)) :: ipiv    ! pivot indices
        integer :: n, info

        real(rk)    :: anorm, rcond
        real(rk)    :: rcond_out

        ! Store A in Ainv to prevent it from being overwritten by LAPACK
        Ainv = A
        n = size(A,1)

        !
        ! Compute matrix 1-norm
        !
        anorm = DLANGE( 'I', n, n, A, n, nwork)

        ! DGETRF computes an LU factorization of a general M-by-N matrix A
        ! using partial pivoting with row interchanges.
        call DGETRF(n, n, Ainv, n, ipiv, info)

        if (info /= 0) then
            stop 'Matrix is numerically singular!'
        end if

        !
        ! DGECON Estimate condition number
        !
        call DGECON('I',n,Ainv,n,anorm,RCOND,conwork,iconwork, info)
        !print*, 'Jacobi condition number: ', ONE/RCOND

        !
        ! RCOND is reciprical of condition number, so invert for output
        !
        rcond_out = ONE/rcond

    end function cond
    !******************************************************************************

end module mod_condition


program main
    use, intrinsic :: iso_fortran_env
    use :: mod_is_positive
    use :: mod_mean
    implicit none

    block
        print *, all([is_positive(-1_int8), &
                      is_positive(-1_int16), &
                      is_positive(-1_int32), &
                      is_positive(-1_int64), &
                      is_positive(-1.0_real32), &
                      is_positive(-1.0_real64)])

        print *, all([is_positive(1_int8), &
                      is_positive(1_int16), &
                      is_positive(1_int32), &
                      is_positive(1_int64), &
                      is_positive(1.0_real32), &
                      is_positive(1.0_real64)])
    end block

    block
        real(real64) :: x5(1, 1, 1, 1, 1)
        real(real64) :: x10(1, 1, 1, 1, 1, &
                            1, 1, 1, 1, 1)
        real(real64) :: x15(1, 1, 1, 1, 1, &
                            1, 1, 1, 1, 1, &
                            1, 1, 1, 1, 1)
        x5 = 5d0
        x10 = 10d0
        x15 = 15d0
        print *, mean(x5), mean(x10), mean(x15)
    end block
end program main


      double precision function arcosh(x)
c!but
c calcule l'arcosinus hyperbolique d'un double precision
c!liste d'appel
c     double precision function arcosh(x)
c     double precision x
c!
c     Copyright INRIA
      double precision x
      if (x.lt.1.0d+0) go to 10
      arcosh = log(x+sqrt(x*x-1.0d+0))
      return
10    arcosh = 0.0d+0
      return
      end
      double precision function arsinh(x)
c!but
c calcule l'arcsinus hyperbolique d'un double precision
c!liste d'appel
c     double precision function arsinh(x)
c     double precision x
c!
      double precision x
c
      arsinh = log(x+sqrt(x*x+1.0d+0))
      return
      end